Changeset 623 for WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- Location:
- WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX
- Files:
-
- 88 edited
-
ECX802.m (modified) (1 diff)
-
ECX8021.m (modified) (1 diff)
-
ECX8022.m (modified) (1 diff)
-
ECX808.m (modified) (1 diff)
-
ECX8081.m (modified) (1 diff)
-
ECX8082.m (modified) (1 diff)
-
ECX809.m (modified) (1 diff)
-
ECX8091.m (modified) (1 diff)
-
ECX8092.m (modified) (1 diff)
-
ECX810.m (modified) (1 diff)
-
ECX8101.m (modified) (1 diff)
-
ECX8102.m (modified) (1 diff)
-
ECX811.m (modified) (1 diff)
-
ECX8111.m (modified) (1 diff)
-
ECX8112.m (modified) (1 diff)
-
ECX813.m (modified) (1 diff)
-
ECX8131.m (modified) (1 diff)
-
ECX8132.m (modified) (1 diff)
-
ECX814.m (modified) (1 diff)
-
ECX8141.m (modified) (1 diff)
-
ECX8142.m (modified) (1 diff)
-
ECX815.m (modified) (1 diff)
-
ECX8151.m (modified) (1 diff)
-
ECX8152.m (modified) (1 diff)
-
ECX817.m (modified) (1 diff)
-
ECX8171.m (modified) (1 diff)
-
ECX8172.m (modified) (1 diff)
-
ECX819.m (modified) (1 diff)
-
ECX8191.m (modified) (1 diff)
-
ECX8192.m (modified) (1 diff)
-
ECX824.m (modified) (1 diff)
-
ECX8241.m (modified) (1 diff)
-
ECX8242.m (modified) (1 diff)
-
ECX825.m (modified) (1 diff)
-
ECX8251.m (modified) (1 diff)
-
ECX8252.m (modified) (1 diff)
-
ECX826.m (modified) (1 diff)
-
ECX8261.m (modified) (1 diff)
-
ECX8262.m (modified) (1 diff)
-
ECX827.m (modified) (1 diff)
-
ECX8271.m (modified) (1 diff)
-
ECX8272.m (modified) (1 diff)
-
ECXADM.m (modified) (1 diff)
-
ECXAPHA2.m (modified) (1 diff)
-
ECXATRT.m (modified) (1 diff)
-
ECXDIVIV.m (modified) (1 diff)
-
ECXDRUG2.m (modified) (1 diff)
-
ECXDVSN.m (modified) (1 diff)
-
ECXDVSN1.m (modified) (1 diff)
-
ECXEC.m (modified) (1 diff)
-
ECXFELOC.m (modified) (1 diff)
-
ECXKILL.m (modified) (1 diff)
-
ECXLABN.m (modified) (1 diff)
-
ECXLABR.m (modified) (1 diff)
-
ECXLBB.m (modified) (1 diff)
-
ECXMOV.m (modified) (1 diff)
-
ECXMTL.m (modified) (1 diff)
-
ECXNUT.m (modified) (1 diff)
-
ECXNUT1.m (modified) (1 diff)
-
ECXOPRX.m (modified) (1 diff)
-
ECXOPRX1.m (modified) (1 diff)
-
ECXPIVDN.m (modified) (1 diff)
-
ECXPLBB.m (modified) (1 diff)
-
ECXPRO.m (modified) (1 diff)
-
ECXPRO1.m (modified) (1 diff)
-
ECXPURG.m (modified) (1 diff)
-
ECXPURG1.m (modified) (1 diff)
-
ECXQSR.m (modified) (1 diff)
-
ECXRAD.m (modified) (1 diff)
-
ECXSCLD.m (modified) (1 diff)
-
ECXSCX1.m (modified) (1 diff)
-
ECXSCX2.m (modified) (1 diff)
-
ECXSCXN.m (modified) (1 diff)
-
ECXSCXN1.m (modified) (1 diff)
-
ECXSURG.m (modified) (1 diff)
-
ECXTRAC.m (modified) (1 diff)
-
ECXTREX.m (modified) (1 diff)
-
ECXTRT.m (modified) (1 diff)
-
ECXUD.m (modified) (1 diff)
-
ECXUPRO.m (modified) (1 diff)
-
ECXUPRO1.m (modified) (1 diff)
-
ECXUSUR.m (modified) (1 diff)
-
ECXUSUR1.m (modified) (1 diff)
-
ECXUTL2.m (modified) (1 diff)
-
ECXUTL3.m (modified) (1 diff)
-
ECXUTL4.m (modified) (1 diff)
-
ECXUTL5.m (modified) (1 diff)
-
ECXUTL6.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX802.m
r613 r623 1 ECX802 ; DRIVER FOR COMPILED XREFS FOR FILE #727.802 ; 12/ 13/081 ECX802 ; DRIVER FOR COMPILED XREFS FOR FILE #727.802 ; 12/27/07 2 2 ; 3 3 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 -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX8021.m
r613 r623 1 ECX8021 ; COMPILED XREF FOR FILE #727.802 ; 12/ 13/081 ECX8021 ; COMPILED XREF FOR FILE #727.802 ; 12/27/07 2 2 ; 3 3 S DIKZK=2 -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX8022.m
r613 r623 1 ECX8022 ; COMPILED XREF FOR FILE #727.802 ; 12/ 13/081 ECX8022 ; COMPILED XREF FOR FILE #727.802 ; 12/27/07 2 2 ; 3 3 S DIKZK=1 -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX808.m
r613 r623 1 ECX808 ; DRIVER FOR COMPILED XREFS FOR FILE #727.808 ; 12/ 13/081 ECX808 ; DRIVER FOR COMPILED XREFS FOR FILE #727.808 ; 12/27/07 2 2 ; 3 3 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 -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX8081.m
r613 r623 1 ECX8081 ; COMPILED XREF FOR FILE #727.808 ; 12/ 13/081 ECX8081 ; COMPILED XREF FOR FILE #727.808 ; 12/27/07 2 2 ; 3 3 S DIKZK=2 -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX8082.m
r613 r623 1 ECX8082 ; COMPILED XREF FOR FILE #727.808 ; 12/ 13/081 ECX8082 ; COMPILED XREF FOR FILE #727.808 ; 12/27/07 2 2 ; 3 3 S DIKZK=1 -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX809.m
r613 r623 1 ECX809 ; DRIVER FOR COMPILED XREFS FOR FILE #727.809 ; 12/ 13/081 ECX809 ; DRIVER FOR COMPILED XREFS FOR FILE #727.809 ; 12/27/07 2 2 ; 3 3 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 -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX8091.m
r613 r623 1 ECX8091 ; COMPILED XREF FOR FILE #727.809 ; 12/ 13/081 ECX8091 ; COMPILED XREF FOR FILE #727.809 ; 12/27/07 2 2 ; 3 3 S DIKZK=2 -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX8092.m
r613 r623 1 ECX8092 ; COMPILED XREF FOR FILE #727.809 ; 12/ 13/081 ECX8092 ; COMPILED XREF FOR FILE #727.809 ; 12/27/07 2 2 ; 3 3 S DIKZK=1 -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX810.m
r613 r623 1 ECX810 ; DRIVER FOR COMPILED XREFS FOR FILE #727.81 ; 12/ 13/081 ECX810 ; DRIVER FOR COMPILED XREFS FOR FILE #727.81 ; 12/27/07 2 2 ; 3 3 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 -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX8101.m
r613 r623 1 ECX8101 ; COMPILED XREF FOR FILE #727.81 ; 12/ 13/081 ECX8101 ; COMPILED XREF FOR FILE #727.81 ; 12/27/07 2 2 ; 3 3 S DIKZK=2 -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX8102.m
r613 r623 1 ECX8102 ; COMPILED XREF FOR FILE #727.81 ; 12/ 13/081 ECX8102 ; COMPILED XREF FOR FILE #727.81 ; 12/27/07 2 2 ; 3 3 S DIKZK=1 -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX811.m
r613 r623 1 ECX811 ; DRIVER FOR COMPILED XREFS FOR FILE #727.811 ; 12/ 13/081 ECX811 ; DRIVER FOR COMPILED XREFS FOR FILE #727.811 ; 12/25/06 2 2 ; 3 3 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 -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX8111.m
r613 r623 1 ECX8111 ; COMPILED XREF FOR FILE #727.811 ; 12/ 13/081 ECX8111 ; COMPILED XREF FOR FILE #727.811 ; 12/25/06 2 2 ; 3 3 S DIKZK=2 -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX8112.m
r613 r623 1 ECX8112 ; COMPILED XREF FOR FILE #727.811 ; 12/ 13/081 ECX8112 ; COMPILED XREF FOR FILE #727.811 ; 12/25/06 2 2 ; 3 3 S DIKZK=1 -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX813.m
r613 r623 1 ECX813 ; DRIVER FOR COMPILED XREFS FOR FILE #727.813 ; 12/ 13/081 ECX813 ; DRIVER FOR COMPILED XREFS FOR FILE #727.813 ; 12/27/07 2 2 ; 3 3 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 -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX8131.m
r613 r623 1 ECX8131 ; COMPILED XREF FOR FILE #727.813 ; 12/ 13/081 ECX8131 ; COMPILED XREF FOR FILE #727.813 ; 12/27/07 2 2 ; 3 3 S DIKZK=2 -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX8132.m
r613 r623 1 ECX8132 ; COMPILED XREF FOR FILE #727.813 ; 12/ 13/081 ECX8132 ; COMPILED XREF FOR FILE #727.813 ; 12/27/07 2 2 ; 3 3 S DIKZK=1 -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX814.m
r613 r623 1 ECX814 ; DRIVER FOR COMPILED XREFS FOR FILE #727.814 ; 12/ 13/081 ECX814 ; DRIVER FOR COMPILED XREFS FOR FILE #727.814 ; 12/25/06 2 2 ; 3 3 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 -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX8141.m
r613 r623 1 ECX8141 ; COMPILED XREF FOR FILE #727.814 ; 12/ 13/081 ECX8141 ; COMPILED XREF FOR FILE #727.814 ; 12/25/06 2 2 ; 3 3 S DIKZK=2 -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX8142.m
r613 r623 1 ECX8142 ; COMPILED XREF FOR FILE #727.814 ; 12/ 13/081 ECX8142 ; COMPILED XREF FOR FILE #727.814 ; 12/25/06 2 2 ; 3 3 S DIKZK=1 -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX815.m
r613 r623 1 ECX815 ; DRIVER FOR COMPILED XREFS FOR FILE #727.815 ; 12/ 13/081 ECX815 ; DRIVER FOR COMPILED XREFS FOR FILE #727.815 ; 12/25/06 2 2 ; 3 3 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 -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX8151.m
r613 r623 1 ECX8151 ; COMPILED XREF FOR FILE #727.815 ; 12/ 13/081 ECX8151 ; COMPILED XREF FOR FILE #727.815 ; 12/25/06 2 2 ; 3 3 S DIKZK=2 -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX8152.m
r613 r623 1 ECX8152 ; COMPILED XREF FOR FILE #727.815 ; 12/ 13/081 ECX8152 ; COMPILED XREF FOR FILE #727.815 ; 12/25/06 2 2 ; 3 3 S DIKZK=1 -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX817.m
r613 r623 1 ECX817 ; DRIVER FOR COMPILED XREFS FOR FILE #727.817 ; 12/ 13/081 ECX817 ; DRIVER FOR COMPILED XREFS FOR FILE #727.817 ; 12/27/07 2 2 ; 3 3 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 -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX8171.m
r613 r623 1 ECX8171 ; COMPILED XREF FOR FILE #727.817 ; 12/ 13/081 ECX8171 ; COMPILED XREF FOR FILE #727.817 ; 12/27/07 2 2 ; 3 3 S DIKZK=2 -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX8172.m
r613 r623 1 ECX8172 ; COMPILED XREF FOR FILE #727.817 ; 12/ 13/081 ECX8172 ; COMPILED XREF FOR FILE #727.817 ; 12/27/07 2 2 ; 3 3 S DIKZK=1 -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX819.m
r613 r623 1 ECX819 ; DRIVER FOR COMPILED XREFS FOR FILE #727.819 ; 12/ 13/081 ECX819 ; DRIVER FOR COMPILED XREFS FOR FILE #727.819 ; 12/27/07 2 2 ; 3 3 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 -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX8191.m
r613 r623 1 ECX8191 ; COMPILED XREF FOR FILE #727.819 ; 12/ 13/081 ECX8191 ; COMPILED XREF FOR FILE #727.819 ; 12/27/07 2 2 ; 3 3 S DIKZK=2 -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX8192.m
r613 r623 1 ECX8192 ; COMPILED XREF FOR FILE #727.819 ; 12/ 13/081 ECX8192 ; COMPILED XREF FOR FILE #727.819 ; 12/27/07 2 2 ; 3 3 S DIKZK=1 -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX824.m
r613 r623 1 ECX824 ; DRIVER FOR COMPILED XREFS FOR FILE #727.824 ; 12/ 13/081 ECX824 ; DRIVER FOR COMPILED XREFS FOR FILE #727.824 ; 12/27/07 2 2 ; 3 3 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 -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX8241.m
r613 r623 1 ECX8241 ; COMPILED XREF FOR FILE #727.824 ; 12/ 13/081 ECX8241 ; COMPILED XREF FOR FILE #727.824 ; 12/27/07 2 2 ; 3 3 S DIKZK=2 -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX8242.m
r613 r623 1 ECX8242 ; COMPILED XREF FOR FILE #727.824 ; 12/ 13/081 ECX8242 ; COMPILED XREF FOR FILE #727.824 ; 12/27/07 2 2 ; 3 3 S DIKZK=1 -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX825.m
r613 r623 1 ECX825 ; DRIVER FOR COMPILED XREFS FOR FILE #727.825 ; 12/ 13/081 ECX825 ; DRIVER FOR COMPILED XREFS FOR FILE #727.825 ; 12/25/06 2 2 ; 3 3 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 -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX8251.m
r613 r623 1 ECX8251 ; COMPILED XREF FOR FILE #727.825 ; 12/ 13/081 ECX8251 ; COMPILED XREF FOR FILE #727.825 ; 12/25/06 2 2 ; 3 3 S DIKZK=2 -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX8252.m
r613 r623 1 ECX8252 ; COMPILED XREF FOR FILE #727.825 ; 12/ 13/081 ECX8252 ; COMPILED XREF FOR FILE #727.825 ; 12/25/06 2 2 ; 3 3 S DIKZK=1 -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX826.m
r613 r623 1 ECX826 ; DRIVER FOR COMPILED XREFS FOR FILE #727.826 ; 12/ 13/081 ECX826 ; DRIVER FOR COMPILED XREFS FOR FILE #727.826 ; 12/25/06 2 2 ; 3 3 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 -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX8261.m
r613 r623 1 ECX8261 ; COMPILED XREF FOR FILE #727.826 ; 12/ 13/081 ECX8261 ; COMPILED XREF FOR FILE #727.826 ; 12/25/06 2 2 ; 3 3 S DIKZK=2 -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX8262.m
r613 r623 1 ECX8262 ; COMPILED XREF FOR FILE #727.826 ; 12/ 13/081 ECX8262 ; COMPILED XREF FOR FILE #727.826 ; 12/25/06 2 2 ; 3 3 S DIKZK=1 -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX827.m
r613 r623 1 ECX827 ; DRIVER FOR COMPILED XREFS FOR FILE #727.827 ; 12/ 13/081 ECX827 ; DRIVER FOR COMPILED XREFS FOR FILE #727.827 ; 12/27/07 2 2 ; 3 3 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 -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX8271.m
r613 r623 1 ECX8271 ; COMPILED XREF FOR FILE #727.827 ; 12/ 13/081 ECX8271 ; COMPILED XREF FOR FILE #727.827 ; 12/27/07 2 2 ; 3 3 S DIKZK=2 -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX8272.m
r613 r623 1 ECX8272 ; COMPILED XREF FOR FILE #727.827 ; 12/ 13/081 ECX8272 ; COMPILED XREF FOR FILE #727.827 ; 12/27/07 2 2 ; 3 3 S DIKZK=1 -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXADM.m
r613 r623 1 ECXADM ;ALB/JAP,BIR/DMA,CML,PTD-Admissions Extract ; 10/15/07 12:14pm 2 ;;3.0;DSS EXTRACTS;**1,4,11,8,13,24,33,39,46,71,84,92,107,105**;Dec 22, 1997;Build 70 3 BEG ;entry point from option 4 D SETUP I ECFILE="" Q 5 D ^ECXTRAC,^ECXKILL 6 Q 7 ; 8 START ; start package specific extract 9 S QFLG=0 10 S ECED=ECED+.3,ECD=ECSD1 11 F S ECD=$O(^DGPM("ATT1",ECD)),ECDA=0 Q:('ECD)!(ECD>ECED) D 12 .F S ECDA=$O(^DGPM("ATT1",ECD,ECDA)) Q:ECDA="" D 13 ..I $D(^DGPM(ECDA,0)) D 14 ...S EC=^DGPM(ECDA,0),ECXDFN=$P(EC,U,3) D GET 15 Q 16 ; 17 GET ;gather extract data 18 N ADM,W,X,ECXNPRFI,ECXATTPC,ECXPRVPC,ECXEST 19 ;patient demographics 20 S ECXERR=0 D PAT(ECXDFN,ECD,.ECXERR) 21 Q:ECXERR 22 I $$ENROLLM^ECXUTL2(ECXDFN) 23 S ECXFAC=$P($G(^DIC(42,+$P(EC,U,6),0)),U,11) 24 S ECXPDIV=$$GETDIV^ECXDEPT(ECXFAC) ;Get production division 25 ;admission data 26 S ELGA=$P($G(^DIC(8,+$P(EC,U,20),0)),U,9) 27 I ELGA S ELGA=$$ELIG^ECXUTL3(ELGA,ECXSVC) 28 S (ECDRG,ECDIA,ECXSADM)="",ECPTF=+$P(EC,U,16) I ECPTF,$D(^DGPT(ECPTF,"M")) D PTF 29 ;get encounter classification 30 S (ECXAO,ECXECE,ECXIR,ECXMIL,ECXHNC)="",ECXVISIT=$P(EC,U,27) 31 I ECXVISIT'="" D 32 .D VISIT^ECXSCX1(ECXDFN,ECXVISIT,.ECXVIST,.ECXERR) I ECXERR K ECXERR Q 33 .S ECXAO=$G(ECXVIST("AO")),ECXIR=$G(ECXVIST("IR")) 34 .S ECXMIL=$G(ECXVIST("MST")),ECXHNC=$G(ECXVIST("HNC")) 35 .S ECXECE=$G(ECXVIST("PGE")) 36 ;use movement record date & time 37 S ADM=$$INP^ECXUTL2(ECXDFN,ECD) 38 S ECXA=$P(ADM,U),ECXMN=$P(ADM,U,2),ECXSPC=$P(ADM,U,3) 39 S (ECXADMDT,ECXDATE)=$P(ADM,U,4) 40 ;if movement# doesn't match cross-ref ien, then quit 41 Q:ECXMN'=ECDA 42 S ECTM=$$ECXTIME^ECXUTL(ECXDATE) 43 S ECXDATE=$$ECXDATE^ECXUTL(ECXDATE,ECXYM) 44 S W=$P(ADM,U,9) 45 S ECXWRD=$P(W,";",1),ECXFAC=$P(W,";",2),ECXDSSD=$P(W,";",3) 46 S ECXPRV=$P(ADM,U,7),ECXPRNPI="",ECXATT=$P(ADM,U,8),ECXATNPI="" 47 S ECXDOM=$P(ADM,U,10),ECXATTPC=$P(ADM,U,12),ECXPRVPC=$P(ADM,U,11) 48 N ECXUSRTN 49 S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",$E(ECXATT,2,$L(ECXATT)),ECD) 50 S:+ECXUSRTN'>0 ECXUSRTN="" 51 S ECATTNPI=$P(ECXUSRTN,U) 52 S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",$E(ECXPRV,2,$L(ECXPRV)),ECD) 53 S:+ECXUSRTN'>0 ECXUSRTN="" 54 S ECPWNPI=$P(ECXUSRTN,U) 55 ; 56 ;- Observation patient indicator (YES/NO) 57 S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXSPC) 58 ; 59 ;- Patient Type 60 S ECXPTYPE=$$TYPE^ECXUTL5(ECXDFN) 61 ; 62 ;- If null encounter number, don't file record 63 S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,,ECXSPC,ECXOBS,ECHEAD,,) 64 D:ECXENC'="" FILE 65 Q 66 ; 67 PAT(ECXDFN,ECXDATE,ECXERR) ;get patient demographic data 68 N OK,X 69 K ECXPAT 70 S ECXDATE=$P(ECXDATE,".") 71 S OK=$$PAT^ECXUTL3(ECXDFN,ECXDATE,"1;2;3;4;5",.ECXPAT) 72 I 'OK S ECXERR=1 K ECXPAT Q 73 S ECXSSN=ECXPAT("SSN") 74 S ECXPNM=ECXPAT("NAME") 75 S ECXMPI=ECXPAT("MPI") 76 S ECXSEX=ECXPAT("SEX") 77 S ECXDOB=ECXPAT("DOB") 78 S ECXELIG=ECXPAT("ELIG") 79 S ECXVET=ECXPAT("VET") 80 S ECXVNS=ECXPAT("VIETNAM") 81 S ECXPOS=ECXPAT("POS") 82 S ECXMNS=ECXPAT("MEANS") 83 S ECXRACE=ECXPAT("RACE") 84 S ECXRELG=ECXPAT("RELIGION") 85 S ECXEMP=ECXPAT("EMPLOY") 86 S ECXMAR=ECXPAT("MARITAL") 87 S ECXPST=ECXPAT("POW STAT") 88 S ECXPLOC=ECXPAT("POW LOC") 89 S ECXRST=ECXPAT("IR STAT") 90 S ECXAST=ECXPAT("AO STAT") 91 S ECXMST=ECXPAT("MST STAT") 92 S ECXSTATE=ECXPAT("STATE") 93 S ECXCNTY=ECXPAT("COUNTY") 94 S ECXZIP=ECXPAT("ZIP") 95 S ECXENRL=ECXPAT("ENROLL LOC") 96 S ECXSVC=ECXPAT("SC%") 97 S ECXPHI=ECXPAT("PHI") 98 S ECXHI=+$$INSUR^IBBAPI(ECXDFN,ECXDATE) 99 S ECXEST=ECXPAT("EC STAT") 100 ; 101 ;-OEF/OIF Data 102 S ECXOEF=ECXPAT("ECXOEF") 103 S ECXOEFDT=ECXPAT("ECXOEFDT") 104 ; 105 ;- Agent Orange location 106 S ECXAOL=ECXPAT("AOL") 107 ; 108 ; - Head and Neck Cancer Indicator 109 S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) 110 ; - Race and Ethnicity 111 S ECXETH=ECXPAT("ETHNIC") 112 S ECXRC1=ECXPAT("RACE1") 113 ; 114 ;get primary care data 115 S X=$$PRIMARY^ECXUTL2(ECXDFN,ECXDATE) 116 S ECPTTM=$P(X,U),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4) 117 S ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7) 118 ;get combat veteran data 119 I $$CVEDT^ECXUTL5(ECXDFN,ECD) 120 ;get national patient record flag if exist 121 D NPRF^ECXUTL5 122 ;get emergency response indicator (FEMA) 123 S ECXERI=ECXPAT("ERI") 124 Q 125 ; 126 PTF ; get admitting DRG, diagnosis, source of admission from PTF 127 ;use number for DRG and .01 for diagnosis 128 N EC,EC1,ECX 129 S EC=1 I $D(^DGPT(ECPTF,"M",2,0)) S EC=2 130 S EC1=+$P(^DGPT(ECPTF,"M",EC,0),U,5) 131 S ECDRG=$P($G(^DGPT(ECPTF,"M",EC,"P")),U) 132 S ECDIA=$P($G(^ICD9(EC1,0)),U) 133 S ECX=+$P($G(^DGPT(ECPTF,101)),U),ECXSADM=$P($G(^DIC(45.1,ECX,0)),U,11) 134 Q 135 ; 136 FILE ;file the extract record 137 ;node0 138 ;facility^dfn^ssn^name^in/out^day^primary care team^sex^dob^ 139 ;religion^employment status^health ins^state^county^zip^ 140 ;eligibility^vet^vietnam^agent orange^radiation^pow^ 141 ;period of service^means test^marital status^ 142 ;ward^treating specialty^attending physician^mov #^DRG^diagnosis^ 143 ;time^primary care provider^race^primary ward provider 144 ;node1 145 ;mpi^dss dept^attending npi^pc provider npi^ward provider npi^ 146 ;admission elig^mst status^^sharing payor^ 147 ;sharing insurance^enrollment location^ 148 ;pc prov person class^assoc pc provider^assoc pc prov person class^ 149 ;assoc pc prov npi^dom^enrollment cat^enrollment stat^enrollment 150 ;priority^purple heart ind.^obs pat ind^encounter num^agent orange 151 ;loc^production div^pow loc^source of admission^head & neck canc. ind 152 ;^ethnicity^race1^enrollment priority_sub group^user enrollee^patient 153 ;type^combat vet elig^combat vet elig end date^enc cv eligible^ 154 ;national patient record flag ECXNPRFI^att phy person class ECXATTPC 155 ;^primary ward provider person class ECXPRVPC^environ contamin ECXEST 156 ;^emergency response indicator(FEMA) ECXERI^agent orange indic ECXAO 157 ;^environ contam ECXECE^encoun head/neck ECXHNC^encoun MST ECXMIL^rad 158 ;encoun ECXIR^ OEF/OIF ECXOEF^ OEF/OIF return date ECXOEFDT 159 ;^associate pc provider npi ECASNPI^attending physician npi ECATNPI^ 160 ;primary care provider npi ECPTNPI^primary ward provider npi ECPWNPI 161 ; 162 ;Convert specialty to PTF Code 163 ; 164 N ECXDATA 165 S ECXDATA=$$TSDATA^DGACT(42.4,+ECXSPC,.ECXDATA) 166 S ECXSPC=$G(ECXDATA(7)) 167 ; 168 N DA,DIK 169 S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 170 S ECODE=EC7_U_EC23_U_ECXFAC_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U_ECXDATE_U 171 S ECODE=ECODE_ECPTTM_U_ECXSEX_U_ECXDOB_U_ECXRELG_U 172 S ECODE=ECODE_ECXEMP_U_ECXHI_U_ECXSTATE_U_ECXCNTY_U_ECXZIP_U 173 S ECODE=ECODE_ECXELIG_U_ECXVET_U_ECXVNS_U_ECXAST_U_ECXRST_U_ECXPST_U 174 S ECODE=ECODE_ECXPOS_U_ECXMNS_U_ECXMAR_U 175 S ECODE=ECODE_ECXWRD_U_ECXSPC_U_ECXATT_U_ECDA_U_ECDRG_U_ECDIA_U 176 S ECODE=ECODE_ECTM_U_ECPTPR_U_ECXRACE_U_ECXPRV_U 177 S ECODE1=ECXMPI_U_ECXDSSD_U_""_U_""_U_""_U_ELGA_U 178 S ECODE1=ECODE1_ECXMST_U_U_U_U_ECXENRL_U_ECCLAS_U 179 S ECODE1=ECODE1_ECASPR_U_ECCLAS2_U_U_ECXDOM_U_ECXCAT_U 180 S ECODE1=ECODE1_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXPHI_U_ECXOBS_U_ECXENC_U_ECXAOL_U 181 S ECODE1=ECODE1_ECXPDIV_U_ECXPLOC_U_ECXSADM_U_ECXHNCI_U_ECXETH_U 182 S ECODE1=ECODE1_ECXRC1 183 I ECXLOGIC>2004 S ECODE1=ECODE1_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXNPRFI 184 I ECXLOGIC>2005 S ECODE1=ECODE1_U_ECXATTPC_U_ECXPRVPC_U_ECXEST 185 I ECXLOGIC>2006 S ECODE1=ECODE1_U_ECXERI_U_ECXAO_U_ECXECE_U_ECXHNC_U_ECXMIL_U_ECXIR_U 186 I ECXLOGIC>2007 S ECODE2=ECXOEF_U_ECXOEFDT_U_ECASNPI_U_ECATTNPI_U_ECPTNPI_U_ECPWNPI 187 S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,^ECX(ECFILE,EC7,2)=$G(ECODE2) 188 S ECRN=ECRN+1 189 S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA 190 Q 191 ; 192 SETUP ;Set required input for ECXTRAC. 193 S ECHEAD="ADM" 194 D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) 195 Q 196 ; 197 LOCAL ; to extract nightly for local use not to be transmitted to TSI 198 ; should be queued with a 1D frequency 199 D SETUP,^ECXTLOCL,^ECXKILL Q 200 ; 201 QUE ; entry point for the background requeuing handled by ECXTAUTO 202 D SETUP,QUE^ECXTAUTO,^ECXKILL Q 203 ; 1 ECXADM ;ALB/JAP,BIR/DMA,CML,PTD-Admissions Extract ; 04/12/2007 2 ;;3.0;DSS EXTRACTS;**1,4,11,8,13,24,33,39,46,71,84,92,107**;Dec 22, 1997;Build 9 3 BEG ;entry point from option 4 D SETUP I ECFILE="" Q 5 D ^ECXTRAC,^ECXKILL 6 Q 7 ; 8 START ; start package specific extract 9 S QFLG=0 10 S ECED=ECED+.3,ECD=ECSD1 11 F S ECD=$O(^DGPM("ATT1",ECD)),ECDA=0 Q:('ECD)!(ECD>ECED) D 12 .F S ECDA=$O(^DGPM("ATT1",ECD,ECDA)) Q:ECDA="" D 13 ..I $D(^DGPM(ECDA,0)) D 14 ...S EC=^DGPM(ECDA,0),ECXDFN=$P(EC,U,3) D GET 15 Q 16 ; 17 GET ;gather extract data 18 N ADM,W,X,ECXNPRFI,ECXATTPC,ECXPRVPC,ECXEST 19 ;patient demographics 20 S ECXERR=0 D PAT(ECXDFN,ECD,.ECXERR) 21 Q:ECXERR 22 I $$ENROLLM^ECXUTL2(ECXDFN) 23 S ECXFAC=$P($G(^DIC(42,+$P(EC,U,6),0)),U,11) 24 S ECXPDIV=$$GETDIV^ECXDEPT(ECXFAC) ;Get production division 25 ;admission data 26 S ELGA=$P($G(^DIC(8,+$P(EC,U,20),0)),U,9) 27 I ELGA S ELGA=$$ELIG^ECXUTL3(ELGA,ECXSVC) 28 S (ECDRG,ECDIA,ECXSADM)="",ECPTF=+$P(EC,U,16) I ECPTF,$D(^DGPT(ECPTF,"M")) D PTF 29 ;get encounter classification 30 S (ECXAO,ECXECE,ECXIR,ECXMIL,ECXHNC)="",ECXVISIT=$P(EC,U,27) 31 I ECXVISIT'="" D 32 .D VISIT^ECXSCX1(ECXDFN,ECXVISIT,.ECXVIST,.ECXERR) I ECXERR K ECXERR Q 33 .S ECXAO=$G(ECXVIST("AO")),ECXIR=$G(ECXVIST("IR")) 34 .S ECXMIL=$G(ECXVIST("MST")),ECXHNC=$G(ECXVIST("HNC")) 35 .S ECXECE=$G(ECXVIST("PGE")) 36 ;use movement record date & time 37 S ADM=$$INP^ECXUTL2(ECXDFN,ECD) 38 S ECXA=$P(ADM,U),ECXMN=$P(ADM,U,2),ECXSPC=$P(ADM,U,3) 39 S (ECXADMDT,ECXDATE)=$P(ADM,U,4) 40 ;if movement# doesn't match cross-ref ien, then quit 41 Q:ECXMN'=ECDA 42 S ECTM=$$ECXTIME^ECXUTL(ECXDATE) 43 S ECXDATE=$$ECXDATE^ECXUTL(ECXDATE,ECXYM) 44 S W=$P(ADM,U,9) 45 S ECXWRD=$P(W,";",1),ECXFAC=$P(W,";",2),ECXDSSD=$P(W,";",3) 46 S ECXPRV=$P(ADM,U,7),ECXPRNPI="",ECXATT=$P(ADM,U,8),ECXATNPI="" 47 S ECXDOM=$P(ADM,U,10),ECXATTPC=$P(ADM,U,12),ECXPRVPC=$P(ADM,U,11) 48 ; 49 ;- Observation patient indicator (YES/NO) 50 S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXSPC) 51 ; 52 ;- Patient Type 53 S ECXPTYPE=$$TYPE^ECXUTL5(ECXDFN) 54 ; 55 ;- If null encounter number, don't file record 56 S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,,ECXSPC,ECXOBS,ECHEAD,,) 57 D:ECXENC'="" FILE 58 Q 59 ; 60 PAT(ECXDFN,ECXDATE,ECXERR) ;get patient demographic data 61 N OK,X 62 K ECXPAT 63 S ECXDATE=$P(ECXDATE,".") 64 S OK=$$PAT^ECXUTL3(ECXDFN,ECXDATE,"1;2;3;4;5",.ECXPAT) 65 I 'OK S ECXERR=1 K ECXPAT Q 66 S ECXSSN=ECXPAT("SSN") 67 S ECXPNM=ECXPAT("NAME") 68 S ECXMPI=ECXPAT("MPI") 69 S ECXSEX=ECXPAT("SEX") 70 S ECXDOB=ECXPAT("DOB") 71 S ECXELIG=ECXPAT("ELIG") 72 S ECXVET=ECXPAT("VET") 73 S ECXVNS=ECXPAT("VIETNAM") 74 S ECXPOS=ECXPAT("POS") 75 S ECXMNS=ECXPAT("MEANS") 76 S ECXRACE=ECXPAT("RACE") 77 S ECXRELG=ECXPAT("RELIGION") 78 S ECXEMP=ECXPAT("EMPLOY") 79 S ECXMAR=ECXPAT("MARITAL") 80 S ECXPST=ECXPAT("POW STAT") 81 S ECXPLOC=ECXPAT("POW LOC") 82 S ECXRST=ECXPAT("IR STAT") 83 S ECXAST=ECXPAT("AO STAT") 84 S ECXMST=ECXPAT("MST STAT") 85 S ECXSTATE=ECXPAT("STATE") 86 S ECXCNTY=ECXPAT("COUNTY") 87 S ECXZIP=ECXPAT("ZIP") 88 S ECXENRL=ECXPAT("ENROLL LOC") 89 S ECXSVC=ECXPAT("SC%") 90 S ECXPHI=ECXPAT("PHI") 91 S ECXHI=+$$INSUR^IBBAPI(ECXDFN,ECXDATE) 92 S ECXEST=ECXPAT("EC STAT") 93 ; 94 ;- Agent Orange location 95 S ECXAOL=ECXPAT("AOL") 96 ; 97 ; - Head and Neck Cancer Indicator 98 S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) 99 ; - Race and Ethnicity 100 S ECXETH=ECXPAT("ETHNIC") 101 S ECXRC1=ECXPAT("RACE1") 102 ; 103 ;get primary care data 104 S X=$$PRIMARY^ECXUTL2(ECXDFN,ECXDATE) 105 S ECPTTM=$P(X,U),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4) 106 S ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7) 107 ;get combat veteran data 108 I $$CVEDT^ECXUTL5(ECXDFN,ECD) 109 ;get national patient record flag if exist 110 D NPRF^ECXUTL5 111 ;get emergency response indicator (FEMA) 112 S ECXERI=ECXPAT("ERI") 113 Q 114 ; 115 PTF ; get admitting DRG, diagnosis, source of admission from PTF 116 ;use number for DRG and .01 for diagnosis 117 N EC,EC1,ECX 118 S EC=1 I $D(^DGPT(ECPTF,"M",2,0)) S EC=2 119 S EC1=+$P(^DGPT(ECPTF,"M",EC,0),U,5) 120 S ECDRG=$P($G(^DGPT(ECPTF,"M",EC,"P")),U) 121 S ECDIA=$P($G(^ICD9(EC1,0)),U) 122 S ECX=+$P($G(^DGPT(ECPTF,101)),U),ECXSADM=$P($G(^DIC(45.1,ECX,0)),U,11) 123 Q 124 ; 125 FILE ;file the extract record 126 ;node0 127 ;facility^dfn^ssn^name^in/out^day^primary care team^sex^dob^ 128 ;religion^employment status^health ins^state^county^zip^ 129 ;eligibility^vet^vietnam^agent orange^radiation^pow^ 130 ;period of service^means test^marital status^ 131 ;ward^treating specialty^attending physician^mov #^DRG^diagnosis^ 132 ;time^primary care provider^race^primary ward provider 133 ;node1 134 ;mpi^dss dept^attending npi^pc provider npi^ward provider npi^ 135 ;admission elig^mst status^^sharing payor^ 136 ;sharing insurance^enrollment location^ 137 ;pc prov person class^assoc pc provider^assoc pc prov person class^ 138 ;assoc pc prov npi^dom^enrollment cat^enrollment stat^enrollment 139 ;priority^purple heart ind.^obs pat ind^encounter num^agent orange 140 ;loc^production div^pow loc^source of admission^head & neck canc. ind 141 ;^ethnicity^race1^enrollment priority_sub group^user enrollee^patient 142 ;type^combat vet elig^combat vet elig end date^enc cv eligible^ 143 ;national patient record flag ECXNPRFI^att phy person class ECXATTPC 144 ;^primary ward provider person class ECXPRVPC^environ contamin ECXEST 145 ;^emergency response indicator(FEMA) ECXERI^agent orange indic ECXAO 146 ;^environ contam ECXECE^encoun head/neck ECXHNC^encoun MST ECXMIL^rad 147 ;encoun ECXIR 148 ; 149 ;Convert specialty to PTF Code 150 ; 151 N ECXDATA 152 S ECXDATA=$$TSDATA^DGACT(42.4,+ECXSPC,.ECXDATA) 153 S ECXSPC=$G(ECXDATA(7)) 154 ; 155 N DA,DIK 156 S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 157 S ECODE=EC7_U_EC23_U_ECXFAC_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U_ECXDATE_U 158 S ECODE=ECODE_ECPTTM_U_ECXSEX_U_ECXDOB_U_ECXRELG_U 159 S ECODE=ECODE_ECXEMP_U_ECXHI_U_ECXSTATE_U_ECXCNTY_U_ECXZIP_U 160 S ECODE=ECODE_ECXELIG_U_ECXVET_U_ECXVNS_U_ECXAST_U_ECXRST_U_ECXPST_U 161 S ECODE=ECODE_ECXPOS_U_ECXMNS_U_ECXMAR_U 162 S ECODE=ECODE_ECXWRD_U_ECXSPC_U_ECXATT_U_ECDA_U_ECDRG_U_ECDIA_U 163 S ECODE=ECODE_ECTM_U_ECPTPR_U_ECXRACE_U_ECXPRV_U 164 S ECODE1=ECXMPI_U_ECXDSSD_U_ECXATNPI_U_ECPTNPI_U_ECXPRNPI_U_ELGA_U 165 S ECODE1=ECODE1_ECXMST_U_U_U_U_ECXENRL_U_ECCLAS_U 166 S ECODE1=ECODE1_ECASPR_U_ECCLAS2_U_ECASNPI_U_ECXDOM_U_ECXCAT_U 167 S ECODE1=ECODE1_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXPHI_U_ECXOBS_U_ECXENC_U_ECXAOL_U 168 S ECODE1=ECODE1_ECXPDIV_U_ECXPLOC_U_ECXSADM_U_ECXHNCI_U_ECXETH_U 169 S ECODE1=ECODE1_ECXRC1 170 I ECXLOGIC>2004 S ECODE1=ECODE1_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXNPRFI 171 I ECXLOGIC>2005 S ECODE1=ECODE1_U_ECXATTPC_U_ECXPRVPC_U_ECXEST 172 I ECXLOGIC>2006 S ECODE1=ECODE1_U_ECXERI_U_ECXAO_U_ECXECE_U_ECXHNC_U_ECXMIL_U_ECXIR 173 S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1 174 S ECRN=ECRN+1 175 S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA 176 Q 177 ; 178 SETUP ;Set required input for ECXTRAC. 179 S ECHEAD="ADM" 180 D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) 181 Q 182 ; 183 LOCAL ; to extract nightly for local use not to be transmitted to TSI 184 ; should be queued with a 1D frequency 185 D SETUP,^ECXTLOCL,^ECXKILL Q 186 ; 187 QUE ; entry point for the background requeuing handled by ECXTAUTO 188 D SETUP,QUE^ECXTAUTO,^ECXKILL Q 189 ; -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXAPHA2.m
r613 r623 1 ECXAPHA2 ;ALB/TMD-Pharmacy Extracts Unusual Volumes Report ; 10/18/07 2:10pm 2 ;;3.0;DSS EXTRACTS;**40,49,84,104,105**;Dec 22, 1997;Build 70 3 ; 4 EN ; entry point 5 N COUNT,ECUNIT,LINE,ECDFN,ECD,ECDRG,ECDAY,ECDFN,ECQTY,ECUNIT,ECCOST,ECDS 6 K ^TMP($J) 7 S (COUNT,ECDS)=0,ECUNIT="" 8 S ECD=ECSD1,ECED=ECED+.3 9 S LINE=$S(ECXOPT=1:"PRE",ECXOPT=2:"IVP",ECXOPT=3:"UDP",1:"EXIT") 10 D @LINE 11 Q 12 ; 13 PRE ; entry point for PRE data 14 N ECRFL,ECRX,ECREF,ECDATA,ECDATA1,ECPRC,IEN 15 K ^TMP($J,"ECXDSS") 16 ;call pharmacy api pso52ex 17 D EXTRACT^PSO52EX(ECD,ECED,"ECXDSS") 18 S ECREF="RF" 19 ;order thru fills and refills; refill values 0 thru 11 20 ; Note: refill 0 = original fill 21 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 22 ; 23 ;order thru partial fills 24 S ECD=ECSD1,ECREF="P" 25 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 26 K ^TMP($J,"ECXDSS") 27 Q 28 ; 29 PRE2 ; get Prescription data 30 I (ECREF="RF")&(ECRFL) D 31 .S ECQTY=+^TMP($J,"ECXDSS",IEN,ECREF,ECRFL,1) 32 .S ECDS=+^TMP($J,"ECXDSS",IEN,ECREF,ECRFL,1.1) 33 .S ECPRC=^TMP($J,"ECXDSS",IEN,ECREF,ECRFL,1.2) 34 I (ECREF="RF")&('ECRFL) D 35 .S ECQTY=+^TMP($J,"ECXDSS",IEN,7) 36 .S ECDS=+^TMP($J,"ECXDSS",IEN,8) 37 .S ECPRC=+^TMP($J,"ECXDSS",IEN,17) 38 I ECREF="P" D 39 .S ECQTY=+^TMP($J,"ECXDSS",IEN,ECREF,ECRFL,.04) 40 .S ECDS=+^TMP($J,"ECXDSS",IEN,ECREF,ECRFL,.041) 41 .S ECPRC=+^TMP($J,"ECXDSS",IEN,ECREF,ECRFL,.042) 42 ;check to see if quantity>threshold 43 I ECQTY>ECTHLD D 44 .S ECDAY=ECD 45 .S ECDFN=$P(^TMP($J,"ECXDSS",IEN,2),U) 46 .S ECDRG=+$P(^TMP($J,"ECXDSS",IEN,6),U) 47 .S ECCOST=ECQTY*ECPRC 48 .D FILE Q:ECXERR 49 Q 50 ; 51 IVP ; entry point for IVP Data 52 N DFN,ON,DA,SA,ECCOUNT 53 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 54 .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 55 ..S ECDRG=$P(EC,U,4) 56 ..S SA=$S($P(EC,U,8)]"":"A",$P(EC,U,9):"S",1:"") 57 ..; set up new record for first DA for this drug 58 ..I '$D(^TMP($J,SA,ECDRG)) D 59 ...S ECQTY=+$S(SA="A":+$P(EC,U,7),SA="S":+$P(EC,U,9),1:0) 60 ...S ECUNIT=$S(SA="A":$P(EC,U,8),SA="S":"ML",1:"") 61 ...S ECCOST=$P(EC,U,12),ECDFN=DFN 62 ...S ^TMP($J,SA,ECDRG)=ECUNIT_U_ECD_U_ECDFN_U_ECCOST_U_ECQTY 63 ...S ^(ECDRG,1)=0 64 ..; add to qty (0,1, or -1) to total 65 ..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) 66 .; looped thru all DAs for this order - now check for unusual volumes 67 .F SA="S","A" S ECDRG="" F S ECDRG=$O(^TMP($J,SA,ECDRG)) Q:ECDRG="" Q:ECXERR D 68 ..S ECQTY=$P(^TMP($J,SA,ECDRG),U,5),ECCOUNT=^(ECDRG,1) 69 ..S ECQTY=ECQTY*ECCOUNT 70 ..; check to see if quantity is outside of threshold range 71 ..I (ECQTY>ECTHLD)!(ECQTY<-ECTHLD) D 72 ...S ECUNIT=$P(^TMP($J,SA,ECDRG),U) 73 ...S ECDAY=$P(^(ECDRG),U,2) 74 ...S ECDFN=$P(^(ECDRG),U,3) 75 ...S ECCOST=$P(^(ECDRG),U,4)*ECCOUNT 76 ...D FILE Q:ECXERR 77 K ^TMP($J,"A"),^("S") 78 Q 79 ; 80 UDP ; entry point for UDP data 81 N ECXJ,ECDATA 82 F S ECD=$O(^ECX(728.904,"A",ECD)) Q:'ECD Q:ECD>ECED Q:ECXERR D 83 .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 84 ..S DATA=^ECX(728.904,ECXJ,0),ECQTY=$P(DATA,U,5) 85 ..;check to see if quantity>threshold 86 ..I ECQTY>ECTHLD D 87 ...S ECDFN=$P(DATA,U,2),ECDRG=$P(DATA,U,4),ECCOST=$P(DATA,U,8),ECDAY=ECD 88 ...D FILE Q:ECXERR 89 Q 90 ; 91 FILE ; put records in temp file to print later 92 N OK,ECXPAT,ECNAME,ECSSN,ECGNAME,ECNDC,ECPROD,ECFKEY,ECXPHA 93 ; get demographics 94 S OK=$$PAT^ECXUTL3(ECDFN,$P(ECD,"."),"1;",.ECXPAT) 95 I 'OK Q 96 S ECNAME=ECXPAT("NAME") 97 S ECSSN=ECXPAT("SSN") 98 S ECDAY=$E(ECDAY,4,5)_"/"_$E(ECDAY,6,7) 99 ; get drug file data 100 S ECXPHA="",ECXPHA=$$PHAAPI^ECXUTL5(ECDRG) 101 S ECGNAME=$P(ECXPHA,U) 102 S ECNDC=$P(ECXPHA,U,3) 103 S ECNDC=$$RJ^XLFSTR($P(ECNDC,"-"),6,0)_$$RJ^XLFSTR($P(ECNDC,"-",2),4,0)_$$RJ^XLFSTR($P(ECNDC,"-",3),2,0) 104 S ECNDC=$TR(ECNDC,"*",0) 105 S ECPROD=$P(ECXPHA,U,6) 106 S ECPROD=$$RJ^XLFSTR(ECPROD,5,0) 107 S ECFKEY=ECPROD_ECNDC 108 I ECXOPT'=2 S ECUNIT=$P(ECXPHA,U,8) 109 ; file 110 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 111 S COUNT=COUNT+1 112 I COUNT#100=0 I $$S^ZTLOAD S (ZSTOP,ECXERR)=1 113 Q 114 ; 115 EXIT S ECXERR=1 Q 1 ECXAPHA2 ;ALB/TMD-Pharmacy Extracts Unusual Volumes Report ; 2/06/07 10:36am 2 ;;3.0;DSS EXTRACTS;**40,49,84,104**;Dec 22, 1997;Build 8 3 ; 4 EN ; entry point 5 N COUNT,ECUNIT,LINE,ECDFN,ECD,ECDRG,ECDAY,ECDFN,ECQTY,ECUNIT,ECCOST,ECDS 6 K ^TMP($J) 7 S (COUNT,ECDS)=0,ECUNIT="" 8 S ECD=ECSD1,ECED=ECED+.3 9 S LINE=$S(ECXOPT=1:"PRE",ECXOPT=2:"IVP",ECXOPT=3:"UDP",1:"EXIT") 10 D @LINE 11 Q 12 ; 13 PRE ; entry point for PRE data 14 ; order through fills, refills and partial refills 15 N ECRFL,ECRX,ECREF,ECDATA,ECDATA1,ECPRC 16 S ECREF=1 17 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 18 S ECD=ECSD1,ECREF="P" 19 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 20 Q 21 ; 22 PRE2 ; get Prescription data 23 S ECDATA=$G(^PSRX(ECRX,0)) 24 I ECRFL D 25 .S ECDATA1=$G(^PSRX(ECRX,ECREF,ECRFL,0)) 26 .S ECQTY=+$P(ECDATA1,U,4) 27 .S ECDS=+$P(ECDATA1,U,10) 28 .S ECPRC=+$P(ECDATA1,U,11) 29 I 'ECRFL D 30 .S ECQTY=+$P(ECDATA,U,7) 31 .S ECDS=+$P(ECDATA,U,8) 32 .S ECPRC=+$P(ECDATA,U,17) 33 ;check to see if quantity>threshold 34 I ECQTY>ECTHLD D 35 .S ECDAY=ECD 36 .S ECDFN=$P(ECDATA,U,2) 37 .S ECDRG=+$P(ECDATA,U,6) 38 .S ECCOST=ECQTY*ECPRC 39 .D FILE Q:ECXERR 40 Q 41 ; 42 IVP ; entry point for IVP Data 43 N DFN,ON,DA,SA,ECCOUNT 44 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 45 .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 46 ..S ECDRG=$P(EC,U,4) 47 ..S SA=$S($P(EC,U,8)]"":"A",$P(EC,U,9):"S",1:"") 48 ..; set up new record for first DA for this drug 49 ..I '$D(^TMP($J,SA,ECDRG)) D 50 ...S ECQTY=+$S(SA="A":+$P(EC,U,7),SA="S":+$P(EC,U,9),1:0) 51 ...S ECUNIT=$S(SA="A":$P(EC,U,8),SA="S":"ML",1:"") 52 ...S ECCOST=$P(EC,U,12),ECDFN=DFN 53 ...S ^TMP($J,SA,ECDRG)=ECUNIT_U_ECD_U_ECDFN_U_ECCOST_U_ECQTY 54 ...S ^(ECDRG,1)=0 55 ..; add to qty (0,1, or -1) to total 56 ..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) 57 .; looped thru all DAs for this order - now check for unusual volumes 58 .F SA="S","A" S ECDRG="" F S ECDRG=$O(^TMP($J,SA,ECDRG)) Q:ECDRG="" Q:ECXERR D 59 ..S ECQTY=$P(^TMP($J,SA,ECDRG),U,5),ECCOUNT=^(ECDRG,1) 60 ..S ECQTY=ECQTY*ECCOUNT 61 ..; check to see if quantity is outside of threshold range 62 ..I (ECQTY>ECTHLD)!(ECQTY<-ECTHLD) D 63 ...S ECUNIT=$P(^TMP($J,SA,ECDRG),U) 64 ...S ECDAY=$P(^(ECDRG),U,2) 65 ...S ECDFN=$P(^(ECDRG),U,3) 66 ...S ECCOST=$P(^(ECDRG),U,4)*ECCOUNT 67 ...D FILE Q:ECXERR 68 K ^TMP($J,"A"),^("S") 69 Q 70 ; 71 UDP ; entry point for UDP data 72 N ECXJ,ECDATA 73 F S ECD=$O(^ECX(728.904,"A",ECD)) Q:'ECD Q:ECD>ECED Q:ECXERR D 74 .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 75 ..S DATA=^ECX(728.904,ECXJ,0),ECQTY=$P(DATA,U,5) 76 ..;check to see if quantity>threshold 77 ..I ECQTY>ECTHLD D 78 ...S ECDFN=$P(DATA,U,2),ECDRG=$P(DATA,U,4),ECCOST=$P(DATA,U,8),ECDAY=ECD 79 ...D FILE Q:ECXERR 80 Q 81 ; 82 FILE ; put records in temp file to print later 83 N OK,ECXPAT,ECNAME,ECSSN,ECGNAME,ECNDC,ECPROD,ECFKEY,ECXPHA 84 ; get demographics 85 S OK=$$PAT^ECXUTL3(ECDFN,$P(ECD,"."),"1;",.ECXPAT) 86 I 'OK Q 87 S ECNAME=ECXPAT("NAME") 88 S ECSSN=ECXPAT("SSN") 89 S ECDAY=$E(ECDAY,4,5)_"/"_$E(ECDAY,6,7) 90 ; get drug file data 91 S ECXPHA="",ECXPHA=$$PHAAPI^ECXUTL5(ECDRG) 92 S ECGNAME=$P(ECXPHA,U) 93 S ECNDC=$P(ECXPHA,U,3) 94 S ECNDC=$$RJ^XLFSTR($P(ECNDC,"-"),6,0)_$$RJ^XLFSTR($P(ECNDC,"-",2),4,0)_$$RJ^XLFSTR($P(ECNDC,"-",3),2,0) 95 S ECNDC=$TR(ECNDC,"*",0) 96 S ECPROD=$P(ECXPHA,U,6) 97 S ECPROD=$$RJ^XLFSTR(ECPROD,5,0) 98 S ECFKEY=ECPROD_ECNDC 99 I ECXOPT'=2 S ECUNIT=$P(ECXPHA,U,8) 100 ; file 101 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 102 S COUNT=COUNT+1 103 I COUNT#100=0 I $$S^ZTLOAD S (ZSTOP,ECXERR)=1 104 Q 105 ; 106 EXIT S ECXERR=1 Q -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXATRT.m
r613 r623 1 ECXATRT 2 ;;3.0;DSS EXTRACTS;**1,6,8,107,105**;Dec 22, 1997;Build 70 3 4 EN 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 PROCESS 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 ..S ECXTS=$P(DATA,U,15) I ECXTS'="" S ECXTS=$O(^DIC(42.4,"C",$G(ECXTS),0)),$P(DATA,U,15)=ECXTS90 ..S ECXTS=$P(DATA,U,16) I ECXTS'="" S ECXTS=$O(^DIC(42.4,"C",$G(ECXTS),0)),$P(DATA,U,16)=ECXTS91 92 93 ..Q:(NUM(+TS)=1)&(NEWTS=TS)94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 PRINT 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 HEADER 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 1 ECXATRT ;ALB/JAP - TRT Extract Audit Report ;O4/12/2007 2 ;;3.0;DSS EXTRACTS;**1,6,8,107**;Dec 22, 1997;Build 9 3 ; 4 EN ;entry point for TRT extract audit report 5 N %X,%Y,X,Y,DIC,DA,DR,DIQ,DIR 6 S ECXERR=0 7 ;ecxaud=0 for 'extract' audit 8 S ECXHEAD="TRT",ECXAUD=0 9 W !!,"Setup for ",ECXHEAD," Extract Audit Report --",!! 10 ;select extract 11 D AUDIT^ECXUTLA(ECXHEAD,.ECXERR,.ECXARRAY,ECXAUD) 12 Q:ECXERR 13 ;currently, this extract does not capture divisional data 14 S ECXALL=1 15 D TRT^ECXDVSN(.ECXDIV,ECXALL,.ECXERR) 16 I ECXERR=1 D Q 17 .W !!,?5,"Try again later... exiting.",! 18 .D AUDIT^ECXKILL 19 ;determine output device and queue if requested 20 W ! 21 S ECXPGM="PROCESS^ECXATRT",ECXDESC="TRT Extract Audit Report" 22 S ECXSAVE("ECXHEAD")="",ECXSAVE("ECXALL")="",ECXSAVE("ECXDIV(")="",ECXSAVE("ECXARRAY(")="" 23 W ! 24 D DEVICE^ECXUTLA(ECXPGM,ECXDESC,.ECXSAVE) 25 I ECXSAVE("POP")=1 D Q 26 .W !!,?5,"Try again later... exiting.",! 27 .D AUDIT^ECXKILL 28 I ECXSAVE("ZTSK")=0 D 29 .K ECXSAVE,ECXPGM,ECXDESC 30 .D PROCESS^ECXATRT 31 I IO'=IO(0) D ^%ZISC 32 D HOME^%ZIS 33 D AUDIT^ECXKILL 34 Q 35 ; 36 PROCESS ;process data in file #727.817 37 N X,Y,W,DATA,DATE,DIV,IEN,TS,SPEC,FTS,FTSNM,SERV,ECX,QQFLG,CNT,A1,A2,NUM,MN,NEWFTS,NEWSPEC 38 K ^TMP($J,"ECXAUD"),^TMP($J,"ECXSPEC") 39 S (QQFLG,CNT)=0 40 S ECXEXT=ECXARRAY("EXTRACT"),ECXDEF=ECXARRAY("DEF") 41 S X=ECXARRAY("START") D ^%DT S ECXSTART=Y S X=ECXARRAY("END") D ^%DT S ECXEND=Y 42 ;get run date in external format 43 D NOW^%DTC S Y=$E(%,1,12) D DD^%DT S ECXRUN=Y 44 ;set up the specialty array for site/division 45 I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ Q 46 S DIV="" F S DIV=$O(ECXDIV(DIV)) Q:DIV="" D 47 .S DIC="^DIC(42.4,",DR=".01;3",DIQ(0)="E",DIQ="ECX" 48 .S SPEC="" F S SPEC=$O(^DIC(42.4,"B",SPEC)) Q:SPEC="" S TS=$O(^(SPEC,0)) D 49 ..K ECX S DA=TS D EN^DIQ1 50 ..S SPEC=$G(ECX(42.4,TS,.01,"E")),SERV=$G(ECX(42.4,TS,3,"E")) S:SERV="" SERV="Unknown" 51 ..S ^TMP($J,"ECXSPEC",DIV,TS)=0_U_SERV_U_SPEC,NUM(TS)=0 52 ;set up the specialty to facility treating specialty conversion array; 53 ;determine if active between ecxstart and ecxend; 54 ;ignore if facility treating specialty not active within date range of report; 55 S DIC="^DIC(45.7,",DR=".01;1",DIQ(0)="I",DIQ="ECX" 56 S FTSNM="" F S FTSNM=$O(^DIC(45.7,"B",FTSNM)) Q:FTSNM="" S FTS=$O(^(FTSNM,0)) D 57 .K ECX S DA=FTS D EN^DIQ1 58 .S FTSNM=$G(ECX(45.7,FTS,.01,"I")),TS=$G(ECX(45.7,FTS,1,"I")) 59 .Q:TS="" 60 .S A1=$$ACTIVE^DGACT(45.7,FTS,ECXSTART),A2=$$ACTIVE^DGACT(45.7,FTS,ECXEND) 61 .Q:A1=0&(A2=0) 62 .;num(ts) will hold the number of active facility treat. specialties (file #45.7) associated 63 .;with this national specialty (file #42.4). 64 .I '$D(NUM(TS)) S NUM(TS)=0 65 .S ^TMP($J,"ECXTS",TS,FTS)=FTSNM,^TMP($J,"ECXREVTS",FTS)=TS,NUM(TS)=NUM(TS)+1 66 ;get extract records in date range 67 S IEN="" F S IEN=$O(^ECX(727.817,"AC",ECXEXT,IEN)) Q:IEN="" D Q:QQFLG 68 .S DATA=^ECX(727.817,IEN,0),DATE=$P(DATA,U,9),DIV=$P(DATA,U,4) 69 .;currently the 4th piece of extract record is always null for trt 70 .S:DIV="" DIV=1 71 .;convert free text date to fm internal format date 72 .S $E(DATE,1,2)=$E(DATE,1,2)-17 73 .Q:$L(DATE)<7 Q:(DATE<ECXSTART) Q:(DATE>ECXEND) 74 .I $D(ECXDIV(DIV)) D 75 ..;ts is the old specialty, newfts is the new facility treat. spec. for the movement date; 76 ..;after patch #1 'losing treating specialty los' field (#17) is non-null only for actual specialty changes; 77 ..;so should be able to distinguish true ts changes from provider-only changes; 78 ..;although it will still be possible that old and new specialty are the same, but facility 79 ..;treat. spec. was changed, but we've lost that info in the extract. 80 ..; 81 ..;filter out those records which are definitely provider-only changes; 82 ..;these are the records that have 'losing treating specialty los' which is null; 83 ..;but for extracts done prior to patch #1, still need to compare old & new specialty. 84 ..; 85 ..;convert 15th and 16th piece from PTF code back to Specialty 86 ..;ECX*3.0*107 87 ..; 88 ..N ECXTS 89 ..S ECXTS=$P(DATA,U,15),ECXTS=$O(^DIC(42.4,$G(ECXTS),"C",$P(DATA,U,15),0)),$P(DATA,U,15)=ECXTS 90 ..S ECXTS=$P(DATA,U,16),ECXTS=$O(^DIC(42.4,$G(ECXTS),"C",$P(DATA,U,16),0)),$P(DATA,U,16)=ECXTS 91 ..S NEWTS=$P(DATA,U,15),TS=$P(DATA,U,16),LOS=$P(DATA,U,17) 92 ..;leaving this next line in here for v3.0 extracts done prior to patch #1 93 ..Q:(NUM(TS)=1)&(NEWTS=TS) 94 ..Q:LOS="" 95 ..S $P(^(TS),U,1)=$P(^TMP($J,"ECXSPEC",DIV,TS),U,1)+1,CNT=CNT+1 96 ..I $D(ZTQUEUED),(CNT>499),'(CNT#500),$$S^%ZTLOAD S QQFLG=1,ZTSTOP=1 K ZTREQ 97 ;after all extract records processed, arrange by service and specialty; 98 ;total can only be associated with specialty, not facility treating specialty; 99 ;include specialty only if total loss is non-zero 100 I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ Q 101 S DIV="" F S DIV=$O(ECXDIV(DIV)) Q:DIV="" I $D(^TMP($J,"ECXSPEC",DIV)) D 102 .S TS="" F S TS=$O(^TMP($J,"ECXSPEC",DIV,TS)) Q:TS="" D 103 ..S TOT=+$P(^TMP($J,"ECXSPEC",DIV,TS),U,1) I TOT>0 D 104 ...S SERV=$P(^(TS),U,2),SPEC=$P(^(TS),U,3) 105 ...S ^TMP($J,"ECXAUD",DIV,SERV,SPEC)=TOT_U_TS 106 ;print the report 107 D PRINT 108 D AUDIT^ECXKILL 109 Q 110 ; 111 PRINT ;print trt data by site, by service, by specialty 112 N JJ,SS,LN,P,DIV,DIVNM,GTOT,SVCTOT,PG,QFLG,DIR,DIRUT,DTOUT,DUOUT 113 U IO 114 I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ Q 115 S (QFLG,PG)=0,$P(LN,"-",80)="" 116 ;division associated with the treat. spec. change is not actually known; division is dss site 117 S DIV="" S DIV=$O(ECXDIV(DIV)) Q:DIV="" S GTOT=0 118 D HEADER 119 I '$D(^TMP($J,"ECXAUD",DIV)) D Q 120 .W !!,?5,"No data available for this DSS Site.",!! 121 I $D(^TMP($J,"ECXAUD",DIV)) S SERV="" F S SERV=$O(^TMP($J,"ECXAUD",DIV,SERV)) Q:SERV="" D Q:QFLG 122 .S SVCTOT=0 123 .;write the service name 124 .D:($Y+3>IOSL) HEADER Q:QFLG W !,SERV 125 .S SPEC="" F S SPEC=$O(^TMP($J,"ECXAUD",DIV,SERV,SPEC)) Q:SPEC="" D Q:QFLG 126 ..;write the specialty name and total 127 ..S TOT=$P(^TMP($J,"ECXAUD",DIV,SERV,SPEC),U,1),TS=$P(^(SPEC),U,2) 128 ..W ?22,$E(SPEC,1,30)_" ("_TS_")",?68,$$RJ^XLFSTR(TOT,5," "),! 129 ..S SVCTOT=SVCTOT+TOT,GTOT=GTOT+TOT 130 ..S FTS="" F S FTS=$O(^TMP($J,"ECXTS",TS,FTS)) Q:FTS="" D Q:QFLG 131 ...S FTSNM=^TMP($J,"ECXTS",TS,FTS) 132 ...D:($Y+3>IOSL) HEADER Q:QFLG W ?25,$E(FTSNM,1,30),! 133 .;write the service subtotal 134 .Q:QFLG 135 .W ?22,$E(LN,1,54),! 136 .D:($Y+3>IOSL) HEADER Q:QFLG W "Total for "_SERV_":",?68,$$RJ^XLFSTR(SVCTOT,5," "),! 137 ;write the grandtotal for all services at facility 138 D:($Y+3>IOSL) HEADER Q:QFLG W !!,"Grand Total for all Services:",?68,$$RJ^XLFSTR(GTOT,5," ") 139 ;print the audit descriptive narrative 140 I $E(IOST)'="C" D 141 .W @IOF S PG=PG+1 142 .W !,ECXARRAY("TYPE")_" ("_ECXHEAD_") Extract Audit Report" 143 .W !,"DSS Extract Log #: "_ECXEXT 144 .W !,"Date Range of Audit: "_ECXARRAY("START")_" to "_ECXARRAY("END") 145 .W !,"Report Run Date/Time: "_ECXRUN,?68,"Page: ",PG 146 .W !!,LN,!! 147 .S DIC="^ECX(727.1,",DA=ECXARRAY("DEF"),DR="1" D EN^DIQ 148 I $E(IOST)="C",'QFLG D 149 .S SS=22-$Y F JJ=1:1:SS W ! 150 .S DIR(0)="E" W ! D ^DIR K DIR 151 Q 152 ; 153 HEADER ;header and page control 154 N JJ,SS 155 I $E(IOST)="C" D 156 .S SS=22-$Y F JJ=1:1:SS W ! 157 .I PG>0 S DIR(0)="E" W ! D ^DIR K DIR S:'Y QFLG=1 158 Q:QFLG 159 W:$Y!($E(IOST)="C") @IOF S PG=PG+1 160 ;W !,ECXARRAY("TYPE")_" ("_ECXHEAD_") Extract Audit Report" 161 W !,"Treating Specialty Change"_" ("_ECXHEAD_") Extract Audit Report" 162 W !,"DSS Extract Log #: "_ECXARRAY("EXTRACT") 163 W !,"Date Range of Audit: "_ECXARRAY("START")_" to "_ECXARRAY("END") 164 W !,"Report Run Date/Time: "_ECXRUN 165 W !,"DSS Site: "_$P(ECXDIV(DIV),U,2)_" ("_$P(ECXDIV(DIV),U,3)_")",?68,"Page: "_PG 166 W !!,"Service",?22,"Specialty (DSS Code)",?68,"# of Losses" 167 W !,?25,"Facility Treating Specialty" 168 W !,LN,! 169 Q -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXDIVIV.m
r613 r623 1 ECXDIVIV ;BIR/CML-Enter/Edit and Print IV Room Division ; 3/13/07 10:48am 2 ;;3.0;DSS EXTRACTS;**8,105**;Dec 22, 1997;Build 70 3 ; 4 ED ;enter/edit division field for iv rooms 5 N CHKFLG,DIC,DIE,DA,DR 6 W !!,"This option allows editing of the DIVISION field for IV Rooms.",! 7 S CHKFLG=0,OUT=0 8 D CHK Q:CHKFLG 9 F D Q:OUT 10 .W ! S DIC=59.5,DIC(0)="QEAMZ" D ^DIC 11 .I Y<0 S OUT=1 Q 12 .I $G(^PS(59.5,+Y,"I"))]"" W " *INACTIVE*",$C(7) 13 .S DIE=DIC,DA=+Y 14 .S DR=.02 D ^DIE K DA 15 Q 16 ; 17 PRT ;print worksheet 18 W !!,"This option will produce a worksheet listing all entries in the IV Room file" 19 W !,"(#59.5). It should be used to help DSS and Pharmacy services define and" 20 W !,"review the DIVISION assignments for each IV Room.",!! S QFLG=0 21 S QFLG=0,CHKFLG=0 22 D CHK Q:CHKFLG 23 D EN^XUTMDEVQ("START^ECXDIVIV","DSS - IV Room List") 24 I POP D 25 .W !,"NO DEVICE SELECTED OR REPORT PRINTED!!" 26 .D PAUSE 27 K ^TMP($J,"ECXDSS") 28 Q 29 ; 30 START ;queued entry point 31 N CHKFLG,DIV,DIVNM,INACT,IV,IVRM,JJ,LN1,LN2,PDT,PG,QFLG,SS,X,Y 32 I '$D(DT) S DT=$$HTFM^XLFDT(+$H) 33 K ^TMP("ECXDIVIV",$J),^TMP($J,"ECXDSS") S QFLG=0,IV=0 34 ;call pharmacy encapsulation api and return all iv rooms information 35 D ALL^PSJ59P5(,"??","ECXDSS") 36 F S IV=$O(^TMP($J,"ECXDSS",IV)) Q:'IV D 37 .S IVRM=$G(^TMP($J,"ECXDSS",IV,.01)),DIV=$P($G(^(.02)),U) 38 .S DIVNM=$S(DIV="":"ZZZ",1:$E($P(^DG(40.8,DIV,0),U),1,30)) 39 .K INACT I $P($G(^TMP($J,"ECXDSS",IV,19)),U)]"" S INACT=$P(^(19),U,2) 40 .S ^TMP("ECXDIVIV",$J,DIVNM,IVRM)=$S($D(INACT):INACT,1:"") 41 ;print report 42 S PG=0,PDT=$$FMTE^XLFDT(DT),$P(LN1,"-",81)="",$P(LN2,"_",30)="" 43 D HDR 44 I '$D(^TMP("ECXDIVIV",$J)) W !!,"No Data found for this worksheet." 45 I $D(^TMP("ECXDIVIV",$J)) S DIVNM="" D 46 .F S DIVNM=$O(^TMP("ECXDIVIV",$J,DIVNM)) Q:DIVNM="" Q:QFLG D 47 ..S IVRM="" 48 ..F S IVRM=$O(^TMP("ECXDIVIV",$J,DIVNM,IVRM)) Q:IVRM="" Q:QFLG D 49 ...S INACT=^TMP("ECXDIVIV",$J,DIVNM,IVRM) 50 ...D:$Y+4>IOSL HDR Q:QFLG 51 ...W !!,IVRM,?34,$S(DIVNM="ZZZ":LN2,1:DIVNM),?60,INACT 52 I $E(IOST)="C"&('QFLG) D PAUSE 53 K ^TMP("ECXDIVIV",$J) S:$D(ZTQUEUED) ZTREQ="@" 54 W:$E(IOST)'="C" @IOF 55 D ^%ZISC 56 Q 57 ; 58 HDR ;header 59 I $E(IOST)="C" S SS=22-$Y F JJ=1:1:SS W ! 60 I $E(IOST)="C",PG>0 S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 61 Q:QFLG 62 S PG=PG+1 W:$Y!($E(IOST)="C") @IOF 63 W !,"IV Room Worksheet",?72,"Page: ",PG,!,"Printed ",PDT 64 W !!,"IV ROOM",?34,"DIVISION",?60,"INACTIVE DATE",!,LN1 65 Q 66 ; 67 CHK ;check for existence of necessary files for division functionality 68 S CHKFLG=0 69 D ALL^PSJ59P5(,"??","ECXIV") 70 I '$O(^TMP($J,"ECXIV",0)) D I CHKFLG D EXIT Q 71 .W !,"The IV Room file (#59.5) does not exist!" 72 .S CHKFLG=1 D PAUSE 73 I '$D(^ECX(728.113,0)) D I CHKFLG D EXIT Q 74 .W $C(7),!!,"Your facility appears to be running a version of Inpatient Medications prior to" 75 .W !,"version 4.5 which is necessary to use this option." 76 .S CHKFLG=1 D PAUSE 77 I '$D(^TMP($J,"ECXIV",$O(^TMP($J,"ECXIV",0)),.02)) D 78 .W $C(7),!!,"The Inpatient Medications Patch PSJ*4.5*27 has not yet been installed!" 79 .W !,"It must be loaded before you can proceed with this option." 80 .S CHKFLG=1 D PAUSE 81 EXIT K ^TMP($J,"ECXIV") 82 Q 83 ; 84 PAUSE ;pause screen 85 I $E(IOST)="C" D 86 .S SS=22-$Y F JJ=1:1:SS W ! 87 .S DIR(0)="E" W ! D ^DIR K DIR 88 Q 1 ECXDIVIV ;BIR/CML-Enter/Edit and Print IV Room Division ; [ 11/15/96 11:12 AM ] 2 ;;3.0;DSS EXTRACTS;**8**;Dec 22, 1997 3 ; 4 ED ;enter/edit division field for iv rooms 5 N CHKFLG,DIC,DIE,DA,DR 6 W !!,"This option allows editing of the DIVISION field for IV Rooms.",! 7 S CHKFLG=0,OUT=0 8 D CHK Q:CHKFLG 9 F D Q:OUT 10 .W ! S DIC=59.5,DIC(0)="QEAMZ" D ^DIC 11 .I Y<0 S OUT=1 Q 12 .I $G(^PS(59.5,+Y,"I"))]"" W " *INACTIVE*",$C(7) 13 .S DIE=DIC,DA=+Y 14 .S DR=.02 D ^DIE K DA 15 Q 16 ; 17 PRT ;print worksheet 18 W !!,"This option will produce a worksheet listing all entries in the IV Room file" 19 W !,"(#59.5). It should be used to help DSS and Pharmacy services define and" 20 W !,"review the DIVISION assignments for each IV Room.",!! S QFLG=0 21 S QFLG=0,CHKFLG=0 22 D CHK Q:CHKFLG 23 D EN^XUTMDEVQ("START^ECXDIVIV","DSS - IV Room List") 24 I POP D 25 .W !,"NO DEVICE SELECTED OR REPORT PRINTED!!" 26 .D PAUSE 27 Q 28 ; 29 START ;queued entry point 30 N CHKFLG,DIV,DIVNM,INACT,IV,IVRM,JJ,LN1,LN2,PDT,PG,QFLG,SS,X,Y 31 I '$D(DT) S DT=$$HTFM^XLFDT(+$H) 32 K ^TMP("ECXDIVIV",$J) S QFLG=0,IV=0 33 F S IV=$O(^PS(59.5,IV)) Q:'IV I $D(^PS(59.5,IV,0)) D 34 .S IVRM=$E($P(^PS(59.5,IV,0),U),1,30),DIV=$P(^(0),U,4) 35 .S DIVNM=$S(DIV="":"ZZZ",1:$E($P(^DG(40.8,DIV,0),U),1,30)) 36 .K INACT I $P($G(^PS(59.5,IV,"I")),U)]"" S INACT=$$FMTE^XLFDT($P(^PS(59.5,IV,"I"),U),1) 37 .S ^TMP("ECXDIVIV",$J,DIVNM,IVRM)=$S($D(INACT):INACT,1:"") 38 ;print report 39 S PG=0,PDT=$$FMTE^XLFDT(DT),$P(LN1,"-",81)="",$P(LN2,"_",30)="" 40 D HDR 41 I '$D(^TMP("ECXDIVIV",$J)) W !!,"No Data found for this worksheet." 42 I $D(^TMP("ECXDIVIV",$J)) S DIVNM="" D 43 .F S DIVNM=$O(^TMP("ECXDIVIV",$J,DIVNM)) Q:DIVNM="" Q:QFLG D 44 ..S IVRM="" 45 ..F S IVRM=$O(^TMP("ECXDIVIV",$J,DIVNM,IVRM)) Q:IVRM="" Q:QFLG D 46 ...S INACT=^TMP("ECXDIVIV",$J,DIVNM,IVRM) 47 ...D:$Y+4>IOSL HDR Q:QFLG 48 ...W !!,IVRM,?34,$S(DIVNM="ZZZ":LN2,1:DIVNM),?60,INACT 49 I $E(IOST)="C"&('QFLG) D PAUSE 50 K ^TMP("ECXDIVIV",$J) S:$D(ZTQUEUED) ZTREQ="@" 51 W:$E(IOST)'="C" @IOF 52 D ^%ZISC 53 Q 54 ; 55 HDR ;header 56 I $E(IOST)="C" S SS=22-$Y F JJ=1:1:SS W ! 57 I $E(IOST)="C",PG>0 S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 58 Q:QFLG 59 S PG=PG+1 W:$Y!($E(IOST)="C") @IOF 60 W !,"IV Room Worksheet",?72,"Page: ",PG,!,"Printed ",PDT 61 W !!,"IV ROOM",?34,"DIVISION",?60,"INACTIVE DATE",!,LN1 62 Q 63 ; 64 CHK ;check for existence of necessary files for division functionality 65 S CHKFLG=0 66 I '$O(^PS(59.5,0)) D Q:CHKFLG 67 .W !,"The IV Room file (#59.5) does not exist!" 68 .S CHKFLG=1 D PAUSE 69 I '$D(^ECX(728.113,0)) D Q:CHKFLG 70 .W $C(7),!!,"Your facility appears to be running a version of Inpatient Medications prior to" 71 .W !,"version 4.5 which is necessary to use this option." 72 .S CHKFLG=1 D PAUSE 73 K TEST1 D FIELD^DID(59.5,.02,"","TYPE","TEST1") 74 I '$D(TEST1) D 75 .W $C(7),!!,"The Inpatient Medications Patch PSJ*4.5*27 has not yet been installed!" 76 .W !,"It must be loaded before you can proceed with this option." 77 .S CHKFLG=1 D PAUSE 78 Q 79 ; 80 PAUSE ;pause screen 81 I $E(IOST)="C" D 82 .S SS=22-$Y F JJ=1:1:SS W ! 83 .S DIR(0)="E" W ! D ^DIR K DIR 84 Q -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXDRUG2.m
r613 r623 1 ECXDRUG2 ;ALB/TMD-Pharmacy Extracts Incomplete Feeder Key Report ; 2/19/08 3:44pm 2 ;;3.0;DSS EXTRACTS;**40,68,84,105,111**;Dec 22, 1997;Build 4 3 ; 4 EN ; entry point 5 N ECD,LINE,ECDRG,ECQTY,ECPRC 6 K ^TMP($J) 7 S ECD=ECSD1,ECED=ECED+.3 8 S LINE=$S(ECXOPT=1:"PRE",ECXOPT=2:"IVP",ECXOPT=3:"UDP",1:"EXIT") 9 D @LINE 10 Q 11 ; 12 PRE ; entry point for PRE data 13 ; order through fills, refills and partial refills 14 N ECRFL,ECRX,ECREF,ECDATA,ECDATA1 15 K ^TMP($J,"ECXDSS") 16 ;call pharmacy api pso52ex 17 D EXTRACT^PSO52EX(ECD,ECED,"ECXDSS") 18 S ECREF="RF" 19 ;order thru fills and refills; refill values 0 thru 11 20 ; Note: refill 0 = original fill 21 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 22 ; 23 ;order thru partial fills 24 S ECD=ECSD1,ECREF="P" 25 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 26 K ^TMP($J,"ECXDSS") 27 Q 28 ; 29 PRE2 ; get Prescription data 30 S ECDRG=+$P(^TMP($J,"ECXDSS",IEN,6),U) 31 I ECRFL>0&(ECREF="RF") D 32 .S ECQTY=^TMP($J,"ECXDSS",IEN,ECREF,ECRFL,1),ECPRC=^(1.2) 33 I ECRFL>0&(ECREF="P") D 34 .S ECQTY=^TMP($J,"ECXDSS",IEN,ECREF,ECRFL,.04),ECPRC=^(.042) 35 I 'ECRFL S ECQTY=^TMP($J,"ECXDSS",IEN,7),ECPRC=^(17) 36 D TEST 37 Q 38 ; 39 IVP ; entry point for IVP data 40 N ON,DFN,DA,SA 41 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 42 .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 43 ..S ECDRG=$P(EC,U,4) 44 ..S SA=$S($P(EC,U,8)]"":"A",$P(EC,U,9):"S",1:"") 45 ..I SA'="" D 46 ...I '$D(^TMP($J,SA,ECDRG)) S ^(ECDRG)=0,$P(^(ECDRG),U,2)=$P(EC,U,12) 47 ...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) 48 .;looped thru all DAs for this order - now put it together 49 .F SA="S","A" S ECDRG="" F S ECDRG=$O(^TMP($J,SA,ECDRG)) Q:ECDRG="" D 50 ..S ECQTY=$P(^TMP($J,SA,ECDRG),U),ECPRC=$P(^(ECDRG),U,2) 51 ..D TEST 52 K ^TMP($J,"A"),^TMP($J,"S") 53 Q 54 ; 55 UDP ; entry point for UDP data 56 N ECXJ,ECDATA 57 F S ECD=$O(^ECX(728.904,"A",ECD)) Q:'ECD Q:ECD>ECED Q:ECXERR D 58 .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 59 ..S DATA=^ECX(728.904,ECXJ,0) 60 ..S ECDRG=$P(DATA,U,4),ECQTY=$P(DATA,U,5),ECCOST=$P(DATA,U,8) 61 ..S ECPRC=ECCOST/ECQTY 62 ..D TEST 63 Q 64 ; 65 TEST ; retrieve NDC and PSNDF VA Product Code Entry and test for missing NDC or VA Prod Code 66 N ECTYPE,ECNDC,ECZERO,K,ECPROD,ECFCHAR,ECSTOCK,ECXPHA 67 S ECTYPE=0,ECXPHA="" 68 ; call pharmacy drug file (#50) api via ecxutl5 69 S ECXPHA=$$PHAAPI^ECXUTL5(ECDRG) 70 S ECNDC=$P(ECXPHA,U,3) 71 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) 72 S ECZERO=1,ECSTOCK=0 F K=1:1:$L(ECNDC) D Q:'ECZERO!ECSTOCK 73 .S ECFCHAR=$E(ECNDC,K) 74 .I ECFCHAR="S" S ECSTOCK=1 Q 75 .I ECFCHAR'=0 S ECZERO=0 Q 76 I ECZERO!ECSTOCK!(ECNDC["N/A") S ECTYPE=2 77 S ECPROD=$P(ECXPHA,U,6),ECPROD=$$RJ^XLFSTR(ECPROD,5,0) 78 I ECTYPE,'ECPROD S ECTYPE=3 79 I 'ECTYPE,'ECPROD S ECTYPE=1 80 I ECTYPE D FILE 81 Q 82 ; 83 FILE ; file record 84 N ECFKEY,ECGNAME,STATS,ECCOUNT,QTY,COST,ECCOST 85 ; create new record if none exists for this drug 86 I '$D(^TMP($J,ECDRG)) D 87 .S ECFKEY=ECPROD_ECNDC 88 .S ECGNAME=$P($G(^PSDRUG(ECDRG,0)),U) 89 .S ^TMP($J,ECDRG)=ECGNAME_U_ECFKEY_U_ECPRC_U_ECTYPE 90 .S ^TMP($J,ECDRG,0)="0^0^0" 91 ; add stats to record 92 S STATS=^TMP($J,ECDRG,0) 93 S ECCOUNT=$P(STATS,U),QTY=$P(STATS,U,2),COST=$P(STATS,U,3) 94 S ECCOUNT=ECCOUNT+1 95 S ECCOST=ECQTY*ECPRC 96 S ECQTY=ECQTY+QTY,ECCOST=ECCOST+COST 97 S ^TMP($J,ECDRG,0)=ECCOUNT_U_ECQTY_U_ECCOST 98 Q 99 ; 100 EXIT S ECXERR=1 Q 1 ECXDRUG2 ;ALB/TMD-Pharmacy Extracts Incomplete Feeder Key Report ; 6/13/05 3:31pm 2 ;;3.0;DSS EXTRACTS;**40,68,84**;Dec 22, 1997 3 ; 4 EN ; entry point 5 N ECD,LINE,ECDRG,ECQTY,ECPRC 6 K ^TMP($J) 7 S ECD=ECSD1,ECED=ECED+.3 8 S LINE=$S(ECXOPT=1:"PRE",ECXOPT=2:"IVP",ECXOPT=3:"UDP",1:"EXIT") 9 D @LINE 10 Q 11 ; 12 PRE ; entry point for PRE data 13 ; order through fills, refills and partial refills 14 N ECRFL,ECRX,ECREF,ECDATA,ECDATA1 15 S ECREF=1 16 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 17 S ECD=ECSD1,ECREF="P" 18 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 19 Q 20 ; 21 PRE2 ; get Prescription data 22 S ECDATA=$G(^PSRX(ECRX,0)) 23 S ECDRG=+$P(ECDATA,U,6) 24 I ECRFL D 25 .S ECDATA1=$G(^PSRX(ECRX,ECREF,ECRFL,0)) 26 .S ECQTY=+$P(ECDATA1,U,4),ECPRC=+$P(ECDATA1,U,11) 27 I 'ECRFL S ECQTY=+$P(ECDATA,U,7),ECPRC=+$P(ECDATA,U,17) 28 D TEST 29 Q 30 ; 31 IVP ; entry point for IVP data 32 N ON,DFN,DA,SA 33 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 34 .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 35 ..S ECDRG=$P(EC,U,4) 36 ..S SA=$S($P(EC,U,8)]"":"A",$P(EC,U,9):"S",1:"") 37 ..I SA'="" D 38 ...I '$D(^TMP($J,SA,ECDRG)) S ^(ECDRG)=0,$P(^(ECDRG),U,2)=$P(EC,U,12) 39 ...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) 40 .;looped thru all DAs for this order - now put it together 41 .F SA="S","A" S ECDRG="" F S ECDRG=$O(^TMP($J,SA,ECDRG)) Q:ECDRG="" D 42 ..S ECQTY=$P(^TMP($J,SA,ECDRG),U),ECPRC=$P(^(ECDRG),U,2) 43 ..D TEST 44 K ^TMP($J,"A"),^TMP($J,"S") 45 Q 46 ; 47 UDP ; entry point for UDP data 48 N ECXJ,ECDATA 49 F S ECD=$O(^ECX(728.904,"A",ECD)) Q:'ECD Q:ECD>ECED Q:ECXERR D 50 .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 51 ..S DATA=^ECX(728.904,ECXJ,0) 52 ..S ECDRG=$P(DATA,U,4),ECQTY=$P(DATA,U,5),ECCOST=$P(DATA,U,8) 53 ..S ECPRC=ECCOST/ECQTY 54 ..D TEST 55 Q 56 ; 57 TEST ; retrieve NDC and PSNDF VA Product Code Entry and test for missing NDC or VA Prod Code 58 N ECTYPE,ECNDC,ECZERO,K,ECPROD,ECFCHAR,ECSTOCK,ECXPHA 59 S ECTYPE=0,ECXPHA="" 60 ; call pharmacy drug file (#50) api via ecxutl5 61 S ECXPHA=$$PHAAPI^ECXUTL5(ECDRG) 62 S ECNDC=$P(ECXPHA,U,3) 63 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) 64 S ECZERO=1,ECSTOCK=0 F K=1:1:$L(ECNDC) D Q:'ECZERO!ECSTOCK 65 .S ECFCHAR=$E(ECNDC,K) 66 .I ECFCHAR="S" S ECSTOCK=1 Q 67 .I ECFCHAR'=0 S ECZERO=0 Q 68 I ECZERO!ECSTOCK!(ECNDC["N/A") S ECTYPE=2 69 S ECPROD=$P(ECXPHA,U,6),ECPROD=$$RJ^XLFSTR(ECPROD,5,0) 70 I ECTYPE,'ECPROD S ECTYPE=3 71 I 'ECTYPE,'ECPROD S ECTYPE=1 72 I ECTYPE D FILE 73 Q 74 ; 75 FILE ; file record 76 N ECFKEY,ECGNAME,STATS,ECCOUNT,QTY,COST,ECCOST 77 ; create new record if none exists for this drug 78 I '$D(^TMP($J,ECDRG)) D 79 .S ECFKEY=ECPROD_ECNDC 80 .S ECGNAME=$P($G(^PSDRUG(ECDRG,0)),U) 81 .S ^TMP($J,ECDRG)=ECGNAME_U_ECFKEY_U_ECPRC_U_ECTYPE 82 .S ^TMP($J,ECDRG,0)="0^0^0" 83 ; add stats to record 84 S STATS=^TMP($J,ECDRG,0) 85 S ECCOUNT=$P(STATS,U),QTY=$P(STATS,U,2),COST=$P(STATS,U,3) 86 S ECCOUNT=ECCOUNT+1 87 S ECCOST=ECQTY*ECPRC 88 S ECQTY=ECQTY+QTY,ECCOST=ECCOST+COST 89 S ^TMP($J,ECDRG,0)=ECCOUNT_U_ECQTY_U_ECCOST 90 Q 91 ; 92 EXIT S ECXERR=1 Q -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXDVSN.m
r613 r623 1 ECXDVSN ;ALB/JAP - Division selection utility ; 8/13/07 1:11pm 2 ;;3.0;DSS EXTRACTS;**8,105**;Dec 22, 1997;Build 70 3 ADM(ECXDIV,ECXALL,ECXSTART,ECXEND,ECXERR) ;division information for ADM extract audit report 4 ;selected inpatient divisions from medical center division file (#40.8) 5 ; input 6 ; ECXDIV = array of inpatient divisions selected (required) 7 ; passed by reference array containing 8 ; selected divisions; 9 ; ECXALL = 1/0 (optional) 10 ; 1==> user wants all inpatient divisions OR 11 ; facility is non-divisional 12 ; 0==> user wants to select some divisions 13 ; if ECXALL not defined, then assume 1 14 ; ECXSTART = start date of date range (optional) 15 ; ECXEND = end date of date range (optional) 16 ; ECXERR = passed by reference for error return (required) 17 ; output 18 ; ECXDIV = array of divisions selected from file #40.8; 19 ; if ECXALL=1, then array contains all divisions 20 ; if ECXALL=0, then array contains user-selected divisions 21 ; ECXDIV(ien in file #40.8) = ien in file #4^name^station number^primary indicator^active indicator^dss id 22 ; error CODE 23 ; ECXERR = 1, if input problem occurs 24 ; 0, otherwise 25 N OUT,DIC,X,Y,NM,ECXD,ECXIEN,ECXDIEN,ECXACT,ECXNAME,ECXNUM 26 S (OUT,ECXERR)=0 27 ;if start date or end date missing, then both default to today 28 I '$G(ECXSTART)!('$G(ECXEND)) S (ECXSTART,ECXEND)=DT 29 S:'$D(ECXALL) ECXALL=1 S:ECXALL="" ECXALL=1 30 I ECXALL=1 D 31 .S NM="" F S NM=$O(^DG(40.8,"B",NM)) Q:NM="" S ECXIEN=$O(^(NM,"")) D 32 ..Q:+$P(^DG(40.8,ECXIEN,0),U,3)=1 33 ..K Y S DIC="^DG(40.8,",DIC(0)="NZ",X=ECXIEN D ^DIC 34 ..Q:Y=-1 35 ..S ECXNAME=$P(Y(0),U,1),ECXNUM=$P(Y(0),U,2),ECXDIEN=$P(Y(0),U,7) 36 ..S ECXDIV(ECXIEN)=ECXDIEN_U_ECXNAME_U_ECXNUM 37 ..D ACTDIV(ECXIEN,ECXSTART,ECXEND,.ECXD,.ECXACT) 38 ..S ECXDIV(ECXIEN)=ECXDIV(ECXIEN)_U_ECXD_U_ECXACT 39 ..I $D(^ECX(727.3,ECXIEN)) D 40 ...S ECXDIV(ECXIEN)=ECXDIV(ECXIEN)_U_$P($G(^ECX(727.3,ECXIEN,0)),U,2) 41 I ECXALL=0 F Q:OUT!ECXERR D 42 .K Y S DIC="^DG(40.8,",DIC(0)="AEMQZ",DIC("S")="I $P(^(0),U,3)'=1" 43 .D ^DIC I $G(DUOUT)!($G(DTOUT)) S OUT=1,ECXERR=1 Q 44 .I Y=-1,X="" S OUT=1 Q 45 .S ECXIEN=+Y,ECXNAME=$P(Y(0),U,1),ECXNUM=$P(Y(0),U,2),ECXDIEN=$P(Y(0),U,7) 46 .S ECXDIV(ECXIEN)=ECXDIEN_U_ECXNAME_U_ECXNUM 47 .D ACTDIV(ECXIEN,ECXSTART,ECXEND,.ECXD,.ECXACT) 48 .S ECXDIV(ECXIEN)=ECXDIV(ECXIEN)_U_ECXD_U_ECXACT 49 .I $D(^ECX(727.3,ECXIEN)) D 50 ..S ECXDIV(ECXIEN)=ECXDIV(ECXIEN)_U_$P($G(^ECX(727.3,ECXIEN,0)),U,2) 51 .I 'ECXACT W !!,?5,"Please note: Division "_ECXNUM_" was not active during",!,?5," selected date range.",! 52 I ECXERR=1 K ECXDIV 53 I '$D(ECXDIV) S ECXERR=1 54 Q 55 ACTDIV(ECXIEN,ECXSTART,ECXEND,ECXD,ECXACT) ;determine if division active at anytime during date range 56 ;to be called by ADM^ECXDVSN 57 ; input 58 ; ECXIEN = ien in file #40.8; required 59 ; ECXSTART = start of date range; FM format; required 60 ; ECXEND = end of date range; FM format; required 61 ; output 62 ; ECXD = 1/0; passed by reference 63 ; 1 indicates primary division 64 ; ECXACT = 1/0; passed by reference 65 ; returns 0, if division not active during date range; 66 ; note: only start date and end date are checked; if division 67 ; inactive on both dates, then division assumed inactive 68 ; for entire date range 69 ;assume division active; set ecxact=1 70 S ECXACT=1 71 ;check if division active on start date or end date; 72 ;these dates are normally within the same month 73 F ECXDATE=ECXSTART,ECXEND D 74 .S DATE(ECXDATE)=$$SITE^VASITE(ECXDATE,ECXIEN) 75 .S ECXD=0 76 .I ECXIEN=$$PRIM^VASITE(ECXDATE) S ECXD=1 77 ;if not active on start date and not active on end date, reset ecxact=0 78 I DATE(ECXSTART)=-1,DATE(ECXEND)=-1 S ECXACT=0 79 Q 80 MOV(ECXDIV,ECXALL,ECXSTART,ECXEND,ECXERR) ;division information for MOV extract audit report 81 ;selected divisions from medical center division file (#40.8) 82 ; input 83 ; (see ADM) 84 ; output 85 ; (see ADM) 86 D ADM^ECXDVSN(.ECXDIV,ECXALL,ECXSTART,ECXEND,.ECXERR) 87 Q 88 PAS(ECXDIV,ECXALL,ECXERR) ;setup division/site information for PAS extract audit report 89 ; input 90 ; ECXDIV = passed by reference array variable 91 ; ECXALL = 1 92 ; output 93 ; ECXDIV = data for default division/site; 94 ; ECXDIV(1)=ien in file #4^name^station number 95 ; where the INSTITUTION file pointer is obtained from file #728 96 S ECXALL=1 D DEFAULT^ECXDVSN(.ECXDIV,ECXALL,.ECXERR) 97 Q 98 TRT(ECXDIV,ECXALL,ECXERR) ;setup division/site information for TRT extract audit report 99 ; input 100 ; ECXDIV = passed by reference array variable 101 ; ECXALL = 1 102 ; output 103 ; ECXDIV = data for default division/site; 104 ; ECXDIV(1)=ien in file #4^name^station number 105 ; where the INSTITUTION file pointer is obtained from file #728 106 S ECXALL=1 D DEFAULT^ECXDVSN(.ECXDIV,ECXALL,.ECXERR) 107 Q 108 DEFAULT(ECXDIV,ECXALL,ECXERR) ;default division/site information for audit report 109 ; input 110 ; ECXDIV = passed by reference array variable 111 ; ECXALL = 1 112 ; output 113 ; ECXDIV = data for default division/site; 114 ; ECXDIV(1)=ien in file #4^name^station number 115 ; where the INSTITUTION file pointer is obtained from file #728 116 N DIV,ECX 117 S ECXERR=0 118 S DIV=$P($G(^ECX(728,1,0)),U,1) 119 I DIV="" S ECXERR=1 Q 120 K ECX S DIC="^DIC(4,",DIQ(0)="I",DIQ="ECX",DA=DIV,DR=".01;99" D EN^DIQ1 121 I $D(ECX) S ECXDIV(1)=DIV_U_ECX(4,DIV,.01,"I")_U_ECX(4,DIV,99,"I") 122 I '$D(ECX) S ECXERR=1 123 I '$D(ECXDIV) S ECXERR=1 124 Q 125 DEN(ECXDIV,ECXALL,ECXERR) ;setup division/site information for DEN extract audit report 126 ; input 127 ; ECXDIV = passed by reference array variable (required) 128 ; ECXALL = 0/1 (optional) 129 ; '0' indicates user to select dental division; 130 ; '1' indicates 'all' dental divisions or only one division 131 ; exists in file #225; default is '1' 132 ; output 133 ; ECXDIV = data for dental division/site; 134 ; ECXDIV(ien in file #225)=ien in file #4^name^station number 135 ; ECXERR = 0/1 136 ; if input problem, then '1' returned 137 N X,Y,DIC,DTOUT,DUOUT,DIRUT,OUT,ECXD,ECXIEN 138 S:'$D(ECXALL) ECXALL=1 S:ECXALL="" ECXALL=1 139 S ECXERR=0,ECXD="" 140 ;if ecxall=1, then all dental divisions/sites 141 I ECXALL=1 D 142 .F S ECXD=$O(^DENT(225,"B",ECXD)) Q:ECXD="" S ECXIEN=$O(^(ECXD,"")) D 143 ..S $P(ECXDIV(ECXIEN),U,3)=ECXD S DIC="^DIC(4,",DIC(0)="MX",X=ECXD D ^DIC 144 ..S:+Y>0 ECXDIV(ECXIEN)=Y S:+Y=-1 ECXDIV(ECXIEN)=U 145 ..S ECXDIV(ECXIEN)=ECXDIV(ECXIEN)_U_ECXD 146 ;if ecxall=0, user selects some/all dental divisions/sites 147 I ECXALL=0 S OUT=0 D 148 .F Q:OUT!ECXERR D 149 ..S DIC="^DENT(225,",DIC(0)="AEMQ" K X,Y D ^DIC 150 ..I $G(DUOUT)!($G(DTOUT)) S OUT=1,ECXERR=1 Q 151 ..I Y=-1,X="" S OUT=1 Q 152 ..S ECXIEN=+Y,ECXD=$P(Y,U,2) K X,Y 153 ..S DIC="^DIC(4,",DIC(0)="MX",X=ECXD D ^DIC 154 ..S:+Y>0 ECXDIV(ECXIEN)=Y S:+Y=-1 ECXDIV(ECXIEN)=U 155 ..S ECXDIV(ECXIEN)=ECXDIV(ECXIEN)_U_ECXD 156 I ECXERR=1 K ECXDIV 157 I '$D(ECXDIV) S ECXERR=1 158 Q 159 ECS(ECXDIV,ECXALL,ECXERR) ;setup division/location information for ECS extract audit report 160 ; input 161 ; ECXDIV = passed by reference array variable (required) 162 ; ECXALL = 0/1 (optional) 163 ; '0' indicates user to select EC location(s); 164 ; '1' indicates 'all' locations or only one location 165 ; exists in file #4 "LOC" index; 166 ; default is '1' 167 ; output 168 ; ECXDIV = data for EC location; 169 ; ECXDIV(ien in file #4)=ien in file #4^name^station number 170 ; where the INSTITUTION file pointer is obtained from 171 ; "LOC" index in file #4 172 ; ECXERR = 0/1 173 ; if input problem, then '1' returned 174 ; 175 N X,Y,I,DIC,DIR,DIRUT,DTOUT,DUOUT,NM,OUT,ECXD,ECXIEN,ECXLOC 176 S:'$D(ECXALL) ECXALL=1 S:ECXALL="" ECXALL=1 177 S ECXERR=0,ECXD="",I=0 178 ;get all available ec locations in ecxloc array 179 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) 180 ;if ecxall=1, then all ec locations 181 I ECXALL=1 S I="" D Q 182 .F S I=$O(ECXLOC(I)) Q:I="" D 183 ..S ECXIEN=$P(ECXLOC(I),U,2) 184 ..S ECXDIV(ECXIEN)=ECXIEN_U_$P(ECXLOC(I),U,1)_U_$P(ECXLOC(I),U,3) 185 I ECXALL=0 S OUT=0,I=0 D 186 .W !!,"Event Capture Locations:",! S I=0,DIR(0)="SXO^" 187 .;spaces are embedded in dir(0) to prevent user from selecting by alpha characters in name 188 .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_";" 189 .W ! 190 .F Q:OUT!ECXERR D 191 ..S DIR("A")="Select Event Capture Location",DIR("S")="I +Y=Y" 192 ..D ^DIR 193 ..I $G(DTOUT)!($G(DUOUT)) S ECXERR=1 Q 194 ..I X="" D Q 195 ...I '$D(ECXDIV) W !!,"No Location selected...exiting.",! S OUT=1 Q 196 ...W !!,"You have selected the following Location(s):",! 197 ...S I=0 F S I=$O(ECXDIV(I)) Q:I="" W !,?10,$P(ECXDIV(I),U,2)_" ("_$P(ECXDIV(I),U,3)_")" 198 ...W ! K X,Y,DIR S DIR(0)="Y",DIR("A")="Is that ok",DIR("B")="YES" D ^DIR 199 ...I $D(DIRUT) S ECXERR=1 200 ...I Y=0 S ECXERR=1 201 ...S OUT=1 202 ..S ECXIEN=$P(ECXLOC(X),U,2) 203 ..S ECXDIV(ECXIEN)=ECXIEN_U_$P(ECXLOC(X),U,1)_U_$P(ECXLOC(X),U,3) 204 ;exit 205 I ECXERR=1 K ECXDIV 206 I '$D(ECXDIV) S ECXERR=1 207 Q 208 NUT() ; Set Divisions into screen array (prompt is one/many/all) 209 ;Input : SCRNARR - Screen array full global reference 210 ;Output : 1 = OK 0 = User abort/timeout 211 ; @SCRNARR@("DIVISION") = User pick all divisions ? 212 ; 1 = Yes (all) 0 = No 213 ; @SCRNARR@("DIVISION",PtrDiv) = Division name 214 ;Note : @SCRNARR@("DIVISION") is initialized (KILLed) on input 215 ; : @SCRNARR@("DIVISION",PtrDiv) is only set when the user 216 ; picked individual divisions (i.e. didn't pick all) 217 ; 218 ;Declare variables 219 N VAUTD,Y,SCANARR 220 ;Get division selection 221 S DIC="^DIC(4," 222 S VAUTSTR="PATIENT DIVISION" 223 S VAUTVB="SCANARR" 224 S VAUTNI=2 225 D FIRST^VAUTOMA 226 I Y<0 Q 1 227 M @SCRNARR@("DIVISION")=SCANARR 228 Q 0 1 ECXDVSN ;ALB/JAP - Division selection utility ;Sep 29, 1997 2 ;;3.0;DSS EXTRACTS;**8**;Dec 22, 1997 3 ; 4 ADM(ECXDIV,ECXALL,ECXSTART,ECXEND,ECXERR) ;division information for ADM extract audit report 5 ;selected inpatient divisions from medical center division file (#40.8) 6 ; input 7 ; ECXDIV = array of inpatient divisions selected (required) 8 ; passed by reference array containing 9 ; selected divisions; 10 ; ECXALL = 1/0 (optional) 11 ; 1==> user wants all inpatient divisions OR 12 ; facility is non-divisional 13 ; 0==> user wants to select some divisions 14 ; if ECXALL not defined, then assume 1 15 ; ECXSTART = start date of date range (optional) 16 ; ECXEND = end date of date range (optional) 17 ; ECXERR = passed by reference for error return (required) 18 ; output 19 ; ECXDIV = array of divisions selected from file #40.8; 20 ; if ECXALL=1, then array contains all divisions 21 ; if ECXALL=0, then array contains user-selected divisions 22 ; ECXDIV(ien in file #40.8) = ien in file #4^name^station number^primary indicator^active indicator^dss id 23 ; error CODE 24 ; ECXERR = 1, if input problem occurs 25 ; 0, otherwise 26 ; 27 N OUT,DIC,X,Y,NM,ECXD,ECXIEN,ECXDIEN,ECXACT,ECXNAME,ECXNUM 28 S (OUT,ECXERR)=0 29 ;if start date or end date missing, then both default to today 30 I '$G(ECXSTART)!('$G(ECXEND)) S (ECXSTART,ECXEND)=DT 31 S:'$D(ECXALL) ECXALL=1 S:ECXALL="" ECXALL=1 32 I ECXALL=1 D 33 .S NM="" F S NM=$O(^DG(40.8,"B",NM)) Q:NM="" S ECXIEN=$O(^(NM,"")) D 34 ..Q:+$P(^DG(40.8,ECXIEN,0),U,3)=1 35 ..K Y S DIC="^DG(40.8,",DIC(0)="NZ",X=ECXIEN D ^DIC 36 ..Q:Y=-1 37 ..S ECXNAME=$P(Y(0),U,1),ECXNUM=$P(Y(0),U,2),ECXDIEN=$P(Y(0),U,7) 38 ..S ECXDIV(ECXIEN)=ECXDIEN_U_ECXNAME_U_ECXNUM 39 ..D ACTDIV(ECXIEN,ECXSTART,ECXEND,.ECXD,.ECXACT) 40 ..S ECXDIV(ECXIEN)=ECXDIV(ECXIEN)_U_ECXD_U_ECXACT 41 ..I $D(^ECX(727.3,ECXIEN)) D 42 ...S ECXDIV(ECXIEN)=ECXDIV(ECXIEN)_U_$P($G(^ECX(727.3,ECXIEN,0)),U,2) 43 I ECXALL=0 F Q:OUT!ECXERR D 44 .K Y S DIC="^DG(40.8,",DIC(0)="AEMQZ",DIC("S")="I $P(^(0),U,3)'=1" 45 .D ^DIC I $G(DUOUT)!($G(DTOUT)) S OUT=1,ECXERR=1 Q 46 .I Y=-1,X="" S OUT=1 Q 47 .S ECXIEN=+Y,ECXNAME=$P(Y(0),U,1),ECXNUM=$P(Y(0),U,2),ECXDIEN=$P(Y(0),U,7) 48 .S ECXDIV(ECXIEN)=ECXDIEN_U_ECXNAME_U_ECXNUM 49 .D ACTDIV(ECXIEN,ECXSTART,ECXEND,.ECXD,.ECXACT) 50 .S ECXDIV(ECXIEN)=ECXDIV(ECXIEN)_U_ECXD_U_ECXACT 51 .I $D(^ECX(727.3,ECXIEN)) D 52 ..S ECXDIV(ECXIEN)=ECXDIV(ECXIEN)_U_$P($G(^ECX(727.3,ECXIEN,0)),U,2) 53 .I 'ECXACT W !!,?5,"Please note: Division "_ECXNUM_" was not active during",!,?5," selected date range.",! 54 I ECXERR=1 K ECXDIV 55 I '$D(ECXDIV) S ECXERR=1 56 Q 57 ; 58 ACTDIV(ECXIEN,ECXSTART,ECXEND,ECXD,ECXACT) ;determine if division active at anytime during date range 59 ;to be called by ADM^ECXDVSN 60 ; input 61 ; ECXIEN = ien in file #40.8; required 62 ; ECXSTART = start of date range; FM format; required 63 ; ECXEND = end of date range; FM format; required 64 ; output 65 ; ECXD = 1/0; passed by reference 66 ; 1 indicates primary division 67 ; ECXACT = 1/0; passed by reference 68 ; returns 0, if division not active during date range; 69 ; note: only start date and end date are checked; if division 70 ; inactive on both dates, then division assumed inactive 71 ; for entire date range 72 ;assume division active; set ecxact=1 73 S ECXACT=1 74 ;check if division active on start date or end date; 75 ;these dates are normally within the same month 76 F ECXDATE=ECXSTART,ECXEND D 77 .S DATE(ECXDATE)=$$SITE^VASITE(ECXDATE,ECXIEN) 78 .S ECXD=0 79 .I ECXIEN=$$PRIM^VASITE(ECXDATE) S ECXD=1 80 ;if not active on start date and not active on end date, reset ecxact=0 81 I DATE(ECXSTART)=-1,DATE(ECXEND)=-1 S ECXACT=0 82 Q 83 ; 84 MOV(ECXDIV,ECXALL,ECXSTART,ECXEND,ECXERR) ;division information for MOV extract audit report 85 ;selected divisions from medical center division file (#40.8) 86 ; input 87 ; (see ADM) 88 ; output 89 ; (see ADM) 90 ; 91 D ADM^ECXDVSN(.ECXDIV,ECXALL,ECXSTART,ECXEND,.ECXERR) 92 Q 93 ; 94 PAS(ECXDIV,ECXALL,ECXERR) ;setup division/site information for PAS extract audit report 95 ; input 96 ; ECXDIV = passed by reference array variable 97 ; ECXALL = 1 98 ; output 99 ; ECXDIV = data for default division/site; 100 ; ECXDIV(1)=ien in file #4^name^station number 101 ; where the INSTITUTION file pointer is obtained from file #728 102 ; 103 S ECXALL=1 D DEFAULT^ECXDVSN(.ECXDIV,ECXALL,.ECXERR) 104 Q 105 ; 106 TRT(ECXDIV,ECXALL,ECXERR) ;setup division/site information for TRT extract audit report 107 ; input 108 ; ECXDIV = passed by reference array variable 109 ; ECXALL = 1 110 ; output 111 ; ECXDIV = data for default division/site; 112 ; ECXDIV(1)=ien in file #4^name^station number 113 ; where the INSTITUTION file pointer is obtained from file #728 114 ; 115 S ECXALL=1 D DEFAULT^ECXDVSN(.ECXDIV,ECXALL,.ECXERR) 116 Q 117 ; 118 DEFAULT(ECXDIV,ECXALL,ECXERR) ;default division/site information for audit report 119 ; input 120 ; ECXDIV = passed by reference array variable 121 ; ECXALL = 1 122 ; output 123 ; ECXDIV = data for default division/site; 124 ; ECXDIV(1)=ien in file #4^name^station number 125 ; where the INSTITUTION file pointer is obtained from file #728 126 ; 127 N DIV,ECX 128 S ECXERR=0 129 S DIV=$P($G(^ECX(728,1,0)),U,1) 130 I DIV="" S ECXERR=1 Q 131 K ECX S DIC="^DIC(4,",DIQ(0)="I",DIQ="ECX",DA=DIV,DR=".01;99" D EN^DIQ1 132 I $D(ECX) S ECXDIV(1)=DIV_U_ECX(4,DIV,.01,"I")_U_ECX(4,DIV,99,"I") 133 I '$D(ECX) S ECXERR=1 134 I '$D(ECXDIV) S ECXERR=1 135 Q 136 ; 137 DEN(ECXDIV,ECXALL,ECXERR) ;setup division/site information for DEN extract audit report 138 ; input 139 ; ECXDIV = passed by reference array variable (required) 140 ; ECXALL = 0/1 (optional) 141 ; '0' indicates user to select dental division; 142 ; '1' indicates 'all' dental divisions or only one division 143 ; exists in file #225; default is '1' 144 ; output 145 ; ECXDIV = data for dental division/site; 146 ; ECXDIV(ien in file #225)=ien in file #4^name^station number 147 ; ECXERR = 0/1 148 ; if input problem, then '1' returned 149 N X,Y,DIC,DTOUT,DUOUT,DIRUT,OUT,ECXD,ECXIEN 150 S:'$D(ECXALL) ECXALL=1 S:ECXALL="" ECXALL=1 151 S ECXERR=0,ECXD="" 152 ;if ecxall=1, then all dental divisions/sites 153 I ECXALL=1 D 154 .F S ECXD=$O(^DENT(225,"B",ECXD)) Q:ECXD="" S ECXIEN=$O(^(ECXD,"")) D 155 ..S $P(ECXDIV(ECXIEN),U,3)=ECXD S DIC="^DIC(4,",DIC(0)="MX",X=ECXD D ^DIC 156 ..S:+Y>0 ECXDIV(ECXIEN)=Y S:+Y=-1 ECXDIV(ECXIEN)=U 157 ..S ECXDIV(ECXIEN)=ECXDIV(ECXIEN)_U_ECXD 158 ;if ecxall=0, user selects some/all dental divisions/sites 159 I ECXALL=0 S OUT=0 D 160 .F Q:OUT!ECXERR D 161 ..S DIC="^DENT(225,",DIC(0)="AEMQ" K X,Y D ^DIC 162 ..I $G(DUOUT)!($G(DTOUT)) S OUT=1,ECXERR=1 Q 163 ..I Y=-1,X="" S OUT=1 Q 164 ..S ECXIEN=+Y,ECXD=$P(Y,U,2) K X,Y 165 ..S DIC="^DIC(4,",DIC(0)="MX",X=ECXD D ^DIC 166 ..S:+Y>0 ECXDIV(ECXIEN)=Y S:+Y=-1 ECXDIV(ECXIEN)=U 167 ..S ECXDIV(ECXIEN)=ECXDIV(ECXIEN)_U_ECXD 168 I ECXERR=1 K ECXDIV 169 I '$D(ECXDIV) S ECXERR=1 170 Q 171 ; 172 ECS(ECXDIV,ECXALL,ECXERR) ;setup division/location information for ECS extract audit report 173 ; input 174 ; ECXDIV = passed by reference array variable (required) 175 ; ECXALL = 0/1 (optional) 176 ; '0' indicates user to select EC location(s); 177 ; '1' indicates 'all' locations or only one location 178 ; exists in file #4 "LOC" index; 179 ; default is '1' 180 ; output 181 ; ECXDIV = data for EC location; 182 ; ECXDIV(ien in file #4)=ien in file #4^name^station number 183 ; where the INSTITUTION file pointer is obtained from 184 ; "LOC" index in file #4 185 ; ECXERR = 0/1 186 ; if input problem, then '1' returned 187 ; 188 N X,Y,I,DIC,DIR,DIRUT,DTOUT,DUOUT,NM,OUT,ECXD,ECXIEN,ECXLOC 189 S:'$D(ECXALL) ECXALL=1 S:ECXALL="" ECXALL=1 190 S ECXERR=0,ECXD="",I=0 191 ;get all available ec locations in ecxloc array 192 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) 193 ;if ecxall=1, then all ec locations 194 I ECXALL=1 S I="" D Q 195 .F S I=$O(ECXLOC(I)) Q:I="" D 196 ..S ECXIEN=$P(ECXLOC(I),U,2) 197 ..S ECXDIV(ECXIEN)=ECXIEN_U_$P(ECXLOC(I),U,1)_U_$P(ECXLOC(I),U,3) 198 I ECXALL=0 S OUT=0,I=0 D 199 .W !!,"Event Capture Locations:",! S I=0,DIR(0)="SXO^" 200 .;spaces are embedded in dir(0) to prevent user from selecting by alpha characters in name 201 .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_";" 202 .W ! 203 .F Q:OUT!ECXERR D 204 ..S DIR("A")="Select Event Capture Location",DIR("S")="I +Y=Y" 205 ..D ^DIR 206 ..I $G(DTOUT)!($G(DUOUT)) S ECXERR=1 Q 207 ..I X="" D Q 208 ...I '$D(ECXDIV) W !!,"No Location selected...exiting.",! S OUT=1 Q 209 ...W !!,"You have selected the following Location(s):",! 210 ...S I=0 F S I=$O(ECXDIV(I)) Q:I="" W !,?10,$P(ECXDIV(I),U,2)_" ("_$P(ECXDIV(I),U,3)_")" 211 ...W ! K X,Y,DIR S DIR(0)="Y",DIR("A")="Is that ok",DIR("B")="YES" D ^DIR 212 ...I $D(DIRUT) S ECXERR=1 213 ...I Y=0 S ECXERR=1 214 ...S OUT=1 215 ..S ECXIEN=$P(ECXLOC(X),U,2) 216 ..S ECXDIV(ECXIEN)=ECXIEN_U_$P(ECXLOC(X),U,1)_U_$P(ECXLOC(X),U,3) 217 ;exit 218 I ECXERR=1 K ECXDIV 219 I '$D(ECXDIV) S ECXERR=1 220 Q -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXDVSN1.m
r613 r623 1 ECXDVSN1 ;ALB/JAP - Division selection utility (cont.) ; 3/30/07 7:56am 2 ;;3.0;DSS EXTRACTS;**8,105**;Dec 22, 1997;Build 70 3 ; 4 ECQ(ECXDIV,ECXALL,ECXERR) ;setup division/site information for QSR extract audit report 5 ; input 6 ; ECXDIV = passed by reference array variable (required) 7 ; ECXALL = 0/1 (optional) 8 ; '0' indicates user to select QUASAR site/division; 9 ; '1' indicates 'all' sites/divisions or only one site/division 10 ; exists in file #509850.8; currently only one site is allowed 11 ; to be defined; 12 ; default is '1' 13 ; output 14 ; ECXDIV = data for QUASAR site/division; 15 ; ECXDIV(ien in file #4)=ien in file #509850.8^name^station number 16 ; ECXERR = 0/1 17 ; if input problem, then '1' returned 18 ; 19 N X,Y,DIC,OUT,ECX,ECXD,ECXIEN 20 S:'$D(ECXALL) ECXALL=1 S:ECXALL="" ECXALL=1 21 ;currently, only ONE site may be defined in file #509850.8 22 S:ECXALL=0 ECXALL=1 23 S ECXERR=0,ECXD="" 24 ;if ecxall=1, then all QUASAR sites/divisions; but there's only one 25 I ECXALL=1 D 26 .F S ECXD=$O(^ACK(509850.8,"B",ECXD)) Q:ECXD="" S ECXIEN=$O(^(ECXD,"")) D 27 ..K ECX S DIC="^DIC(4,",DIQ(0)="I",DIQ="ECX",DA=ECXD,DR=".01;99" D EN^DIQ1 28 ..I $D(ECX) S ECXDIV(ECXD)=ECXIEN_U_ECX(4,ECXD,.01,"I")_U_ECX(4,ECXD,99,"I") 29 ..I '$D(ECX) S ECXERR=1 30 I ECXERR=1 K ECXDIV 31 I '$D(ECXDIV) S ECXERR=1 32 Q 33 ; 34 LAB(ECXACC,ECXALL,ECXERR) ;setup accession area information for LAB extract audit report 35 ; input 36 ; ECXACC = passed by reference array variable (required) 37 ; ECXALL = 0/1 (optional) 38 ; '0' indicates user to select Accession Area(s); 39 ; '1' indicates 'all' Accession Areas are selected 40 ; default is '1' 41 ; output 42 ; ECXACC = data for Accession Area(s); 43 ; ECXACC(ien in file #68)=name^abbreviation 44 ; ECXERR = 0/1 45 ; if input problem, then '1' returned 46 ; 47 N X,Y,DIC,DIQ,DA,DR,DTOUT,DUOUT,DIRUT,OUT,ECX,ECXA,ECXIEN 48 S:'$D(ECXALL) ECXALL=1 S:ECXALL="" ECXALL=1 49 S ECXERR=0,ECXA="" 50 ;if ecxall=1, then all accession areas are selected 51 I ECXALL=1 D 52 .;^LRO(68,"B",xxx,ien)=1 indicates a synonym; skip synonyms 53 .F S ECXA=$O(^LRO(68,"B",ECXA)) Q:ECXA="" S ECXIEN=$O(^(ECXA,"")) D 54 ..Q:^LRO(68,"B",ECXA,ECXIEN)=1 55 ..K ECX S DIC="^LRO(68,",DR=".01;.09",DIQ="ECX",DA=ECXIEN D EN^DIQ1 56 ..Q:'$D(ECX) 57 ..;acc. areas with ZZ in name indicates no longer used 58 ..Q:$E(ECX(68,ECXIEN,.01),1,2)="ZZ" 59 ..S ECXACC(ECXIEN)=ECX(68,ECXIEN,.01)_U_ECX(68,ECXIEN,.09) 60 ;if ecxall=0, user selects some/all acc. areas 61 ;allow user to choose "ZZ"'d acc. area even though it may currently be inactive 62 I ECXALL=0 S OUT=0 D 63 .F Q:OUT!ECXERR D 64 ..S DIC="^LRO(68,",DIC(0)="AEMQZ" K X,Y D ^DIC 65 ..I $G(DUOUT)!($G(DTOUT)) S OUT=1,ECXERR=1 Q 66 ..I Y=-1,X="" S OUT=1 Q 67 ..S ECXACC(+Y)=$P(Y(0),U,1)_U_$P(Y(0),U,11) 68 I ECXERR=1 K ECXACC 69 I '$D(ECXACC) S ECXERR=1 70 Q 71 ; 72 NUR(ECXDIV,ECXALL,ECXERR) ;setup accession area information for LAB extract audit report 73 ; input 74 ; ECXDIV = passed by reference array variable (required) 75 ; ECXALL = 0/1 (optional) 76 ; '0' indicates user to select nursing location(s)/division(s); 77 ; '1' indicates 'all' nursing locations and medical center divisions 78 ; are selected or facility is non-divisional; 79 ; default is '1' 80 ; output 81 ; ECXDIV = data for nursing location(s) and medical center division(s); 82 ; ECXDIV("D",ien in file #40.8)=ien in file #4^name^station number 83 ; ECXDIV(ien in file #211.4,ien in file #40.8)=ien in file #44 84 ; ECXERR = 0/1 85 ; if input problem, then '1' returned 86 ; 87 ;N X,Y,DIC,DIQ,DA,OUT,ECX,ECXLOC,ECXSC,ECXDIEN,ECXNLIEN,ECXNLNM,ECXPRIME 88 S:'$D(ECXALL) ECXALL=1 S:ECXALL="" ECXALL=1 89 S (ECXERR,OUT)=0,ECXSC="" 90 ;get ien in file #40.8 of primary division 91 S ECXPRIME=$$PRIM^VASITE(DT) 92 ;associate nursing locations with medical center divisions 93 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 94 .K ECX 95 .S ECXDIEN=0,ECXNLNM="",DIC="^SC(",DIQ(0)="I",DIQ="ECX",DA=ECXSC,DR=".01;3.5" D EN^DIQ1 96 .;if the 15th piece is null or y=-1 then ecxdien=primary division as default 97 .I $D(ECX) S ECXDIEN=+ECX(44,ECXSC,3.5,"I"),ECXNLNM=ECX(44,ECXSC,.01,"I") 98 .S:ECXDIEN=0 ECXDIEN=ECXPRIME 99 .S ECXLOC(ECXDIEN)="",ECXLOC(ECXDIEN,ECXNLIEN)=ECXSC_U_ECXNLNM 100 ; 101 ;if ecxall=1 don't prompt; setup all nursing locations and divisions incl. those w/o division 102 I ECXALL=1 S ECXDIEN="" D 103 .F S ECXDIEN=$O(ECXLOC(ECXDIEN)) Q:ECXDIEN="" D 104 ..S DIC="^DG(40.8,",DIC(0)="NXZ",X=ECXDIEN D ^DIC I +Y>0 D 105 ...S ECXDIV("D",ECXDIEN)=$P(Y(0),U,7)_U_$P(Y(0),U,1)_U_$P(Y(0),U,2),ECXNLIEN="" 106 ...F S ECXNLIEN=$O(ECXLOC(ECXDIEN,ECXNLIEN)) Q:ECXNLIEN="" S ECXDIV(ECXNLIEN,ECXDIEN)=ECXLOC(ECXDIEN,ECXNLIEN) 107 ; 108 ;if ecxall=0 let user select division(s) 109 I ECXALL=0 F Q:OUT!ECXERR D 110 .S DIC="^DG(40.8,",DIC(0)="AEMQZ",DIC("S")="I $P(^(0),U,3)'=1" 111 .D ^DIC I $G(DUOUT)!($G(DTOUT)) S OUT=1,ECXERR=1 Q 112 .I Y=-1,X="" S OUT=1 Q 113 .S ECXDIEN=+Y,NM=$P(Y,U,2) 114 .I '$D(ECXLOC(ECXDIEN)) D Q 115 ..W !!,?5,"Division "_NM_" not associated with Nursing Locations.",!,?5,"Try again...",! 116 .S ECXDIV("D",ECXDIEN)=$P(Y(0),U,7)_U_$P(Y(0),U,1)_U_$P(Y(0),U,2),ECXNLIEN="" 117 .F S ECXNLIEN=$O(ECXLOC(ECXDIEN,ECXNLIEN)) Q:ECXNLIEN="" S ECXDIV(ECXNLIEN,ECXDIEN)=ECXLOC(ECXDIEN,ECXNLIEN) 118 ;in case of user up-arrow out or timeout, make sure nothing returned in ecxdiv 119 I ECXERR=1 K ECXDIV 120 I '$D(ECXDIV) S ECXERR=1 121 Q 122 ; 123 PRE(ECXDIV,ECXALL,ECXERR) ;setup site information for PRE extract audit report 124 ; input 125 ; ECXDIV = passed by reference array variable (required) 126 ; ECXALL = 0/1 (optional) 127 ; '0' indicates user to select Pharmacy site(s); 128 ; '1' indicates 'all' sites are selected 129 ; default is '1' 130 ; output 131 ; ECXDIV = data for Pharmacy site(s); 132 ; ECXDIV(ien in file #59)=IEN in file #59^name^site number^IEN in file #4 133 ; ECXERR = 0/1 134 ; if input problem, then '1' returned 135 ; 136 N X,Y,DIC,DIQ,DA,OUT,ECXARR,ECXP,ECXIEN,ARRAY 137 S:'$D(ECXALL) ECXALL=1 S:ECXALL="" ECXALL=1 138 S ECXERR=0,ECXP="",ARRAY="^TMP($J,""ECXDSS"")" 139 K @ARRAY 140 ;if ecxall=1, then all pharmacy sites are selected or there's only one 141 I ECXALL=1 S ECXP="" D 142 .D PSS^PSO59(,"??","ECXDSS") 143 .F S ECXP=$O(@ARRAY@("B",ECXP)) Q:ECXP="" S ECXIEN=$O(^(ECXP,0)) Q:'ECXIEN Q:'$D(^(ECXIEN)) D 144 ..S ECXDIV(ECXIEN)=ECXIEN_U_@ARRAY@(ECXIEN,.01)_U_^(.06)_U_^(100) 145 ;if ecxall=0, then user selects pharmacy site(s) 146 I ECXALL=0 S OUT=0 D 147 .F Q:OUT!ECXERR D 148 ..N DIC,X,Y,DUOUT,DTOUT 149 ..S DIC="^PS(59,",DIC(0)="AEMQZ" 150 ..D DIC^PSODI(59,.DIC,.X) 151 ..I $G(DUOUT)!($G(DTOUT)) S OUT=1,ECXERR=1 Q 152 ..I Y=-1,X="" S OUT=1 Q 153 ..D PSS^PSO59(+Y,,"ECXDSS") 154 ..Q:'$D(@ARRAY) 155 ..S ECXDIV(ECXIEN)=ECXIEN_U_@ARRAY@(ECXIEN,.01)_U_^(.06)_U_^(100) 156 ; 157 I ECXERR=1 K ECXDIV 158 I '$D(ECXDIV) S ECXERR=1 159 Q 1 ECXDVSN1 ;ALB/JAP - Division selection utility (cont.) ;Sep 30, 1997 2 ;;3.0;DSS EXTRACTS;**8**;Dec 22, 1997 3 ; 4 ECQ(ECXDIV,ECXALL,ECXERR) ;setup division/site information for QSR extract audit report 5 ; input 6 ; ECXDIV = passed by reference array variable (required) 7 ; ECXALL = 0/1 (optional) 8 ; '0' indicates user to select QUASAR site/division; 9 ; '1' indicates 'all' sites/divisions or only one site/division 10 ; exists in file #509850.8; currently only one site is allowed 11 ; to be defined; 12 ; default is '1' 13 ; output 14 ; ECXDIV = data for QUASAR site/division; 15 ; ECXDIV(ien in file #4)=ien in file #509850.8^name^station number 16 ; ECXERR = 0/1 17 ; if input problem, then '1' returned 18 ; 19 N X,Y,DIC,OUT,ECX,ECXD,ECXIEN 20 S:'$D(ECXALL) ECXALL=1 S:ECXALL="" ECXALL=1 21 ;currently, only ONE site may be defined in file #509850.8 22 S:ECXALL=0 ECXALL=1 23 S ECXERR=0,ECXD="" 24 ;if ecxall=1, then all QUASAR sites/divisions; but there's only one 25 I ECXALL=1 D 26 .F S ECXD=$O(^ACK(509850.8,"B",ECXD)) Q:ECXD="" S ECXIEN=$O(^(ECXD,"")) D 27 ..K ECX S DIC="^DIC(4,",DIQ(0)="I",DIQ="ECX",DA=ECXD,DR=".01;99" D EN^DIQ1 28 ..I $D(ECX) S ECXDIV(ECXD)=ECXIEN_U_ECX(4,ECXD,.01,"I")_U_ECX(4,ECXD,99,"I") 29 ..I '$D(ECX) S ECXERR=1 30 I ECXERR=1 K ECXDIV 31 I '$D(ECXDIV) S ECXERR=1 32 Q 33 ; 34 LAB(ECXACC,ECXALL,ECXERR) ;setup accession area information for LAB extract audit report 35 ; input 36 ; ECXACC = passed by reference array variable (required) 37 ; ECXALL = 0/1 (optional) 38 ; '0' indicates user to select Accession Area(s); 39 ; '1' indicates 'all' Accession Areas are selected 40 ; default is '1' 41 ; output 42 ; ECXACC = data for Accession Area(s); 43 ; ECXACC(ien in file #68)=name^abbreviation 44 ; ECXERR = 0/1 45 ; if input problem, then '1' returned 46 ; 47 N X,Y,DIC,DIQ,DA,DR,DTOUT,DUOUT,DIRUT,OUT,ECX,ECXA,ECXIEN 48 S:'$D(ECXALL) ECXALL=1 S:ECXALL="" ECXALL=1 49 S ECXERR=0,ECXA="" 50 ;if ecxall=1, then all accession areas are selected 51 I ECXALL=1 D 52 .;^LRO(68,"B",xxx,ien)=1 indicates a synonym; skip synonyms 53 .F S ECXA=$O(^LRO(68,"B",ECXA)) Q:ECXA="" S ECXIEN=$O(^(ECXA,"")) D 54 ..Q:^LRO(68,"B",ECXA,ECXIEN)=1 55 ..K ECX S DIC="^LRO(68,",DR=".01;.09",DIQ="ECX",DA=ECXIEN D EN^DIQ1 56 ..Q:'$D(ECX) 57 ..;acc. areas with ZZ in name indicates no longer used 58 ..Q:$E(ECX(68,ECXIEN,.01),1,2)="ZZ" 59 ..S ECXACC(ECXIEN)=ECX(68,ECXIEN,.01)_U_ECX(68,ECXIEN,.09) 60 ;if ecxall=0, user selects some/all acc. areas 61 ;allow user to choose "ZZ"'d acc. area even though it may currently be inactive 62 I ECXALL=0 S OUT=0 D 63 .F Q:OUT!ECXERR D 64 ..S DIC="^LRO(68,",DIC(0)="AEMQZ" K X,Y D ^DIC 65 ..I $G(DUOUT)!($G(DTOUT)) S OUT=1,ECXERR=1 Q 66 ..I Y=-1,X="" S OUT=1 Q 67 ..S ECXACC(+Y)=$P(Y(0),U,1)_U_$P(Y(0),U,11) 68 I ECXERR=1 K ECXACC 69 I '$D(ECXACC) S ECXERR=1 70 Q 71 ; 72 NUR(ECXDIV,ECXALL,ECXERR) ;setup accession area information for LAB extract audit report 73 ; input 74 ; ECXDIV = passed by reference array variable (required) 75 ; ECXALL = 0/1 (optional) 76 ; '0' indicates user to select nursing location(s)/division(s); 77 ; '1' indicates 'all' nursing locations and medical center divisions 78 ; are selected or facility is non-divisional; 79 ; default is '1' 80 ; output 81 ; ECXDIV = data for nursing location(s) and medical center division(s); 82 ; ECXDIV("D",ien in file #40.8)=ien in file #4^name^station number 83 ; ECXDIV(ien in file #211.4,ien in file #40.8)=ien in file #44 84 ; ECXERR = 0/1 85 ; if input problem, then '1' returned 86 ; 87 ;N X,Y,DIC,DIQ,DA,OUT,ECX,ECXLOC,ECXSC,ECXDIEN,ECXNLIEN,ECXNLNM,ECXPRIME 88 S:'$D(ECXALL) ECXALL=1 S:ECXALL="" ECXALL=1 89 S (ECXERR,OUT)=0,ECXSC="" 90 ;get ien in file #40.8 of primary division 91 S ECXPRIME=$$PRIM^VASITE(DT) 92 ;associate nursing locations with medical center divisions 93 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 94 .K ECX 95 .S ECXDIEN=0,ECXNLNM="",DIC="^SC(",DIQ(0)="I",DIQ="ECX",DA=ECXSC,DR=".01;3.5" D EN^DIQ1 96 .;if the 15th piece is null or y=-1 then ecxdien=primary division as default 97 .I $D(ECX) S ECXDIEN=+ECX(44,ECXSC,3.5,"I"),ECXNLNM=ECX(44,ECXSC,.01,"I") 98 .S:ECXDIEN=0 ECXDIEN=ECXPRIME 99 .S ECXLOC(ECXDIEN)="",ECXLOC(ECXDIEN,ECXNLIEN)=ECXSC_U_ECXNLNM 100 ; 101 ;if ecxall=1 don't prompt; setup all nursing locations and divisions incl. those w/o division 102 I ECXALL=1 S ECXDIEN="" D 103 .F S ECXDIEN=$O(ECXLOC(ECXDIEN)) Q:ECXDIEN="" D 104 ..S DIC="^DG(40.8,",DIC(0)="NXZ",X=ECXDIEN D ^DIC I +Y>0 D 105 ...S ECXDIV("D",ECXDIEN)=$P(Y(0),U,7)_U_$P(Y(0),U,1)_U_$P(Y(0),U,2),ECXNLIEN="" 106 ...F S ECXNLIEN=$O(ECXLOC(ECXDIEN,ECXNLIEN)) Q:ECXNLIEN="" S ECXDIV(ECXNLIEN,ECXDIEN)=ECXLOC(ECXDIEN,ECXNLIEN) 107 ; 108 ;if ecxall=0 let user select division(s) 109 I ECXALL=0 F Q:OUT!ECXERR D 110 .S DIC="^DG(40.8,",DIC(0)="AEMQZ",DIC("S")="I $P(^(0),U,3)'=1" 111 .D ^DIC I $G(DUOUT)!($G(DTOUT)) S OUT=1,ECXERR=1 Q 112 .I Y=-1,X="" S OUT=1 Q 113 .S ECXDIEN=+Y,NM=$P(Y,U,2) 114 .I '$D(ECXLOC(ECXDIEN)) D Q 115 ..W !!,?5,"Division "_NM_" not associated with Nursing Locations.",!,?5,"Try again...",! 116 .S ECXDIV("D",ECXDIEN)=$P(Y(0),U,7)_U_$P(Y(0),U,1)_U_$P(Y(0),U,2),ECXNLIEN="" 117 .F S ECXNLIEN=$O(ECXLOC(ECXDIEN,ECXNLIEN)) Q:ECXNLIEN="" S ECXDIV(ECXNLIEN,ECXDIEN)=ECXLOC(ECXDIEN,ECXNLIEN) 118 ;in case of user up-arrow out or timeout, make sure nothing returned in ecxdiv 119 I ECXERR=1 K ECXDIV 120 I '$D(ECXDIV) S ECXERR=1 121 Q 122 ; 123 PRE(ECXDIV,ECXALL,ECXERR) ;setup site information for PRE extract audit report 124 ; input 125 ; ECXDIV = passed by reference array variable (required) 126 ; ECXALL = 0/1 (optional) 127 ; '0' indicates user to select Pharmacy site(s); 128 ; '1' indicates 'all' sites are selected 129 ; default is '1' 130 ; output 131 ; ECXDIV = data for Pharmacy site(s); 132 ; ECXDIV(ien in file #59)=IEN in file #59^name^site number^IEN in file #4 133 ; ECXERR = 0/1 134 ; if input problem, then '1' returned 135 ; 136 N X,Y,DIC,DIQ,DA,OUT,ECXARR,ECXP,ECXIEN 137 S:'$D(ECXALL) ECXALL=1 S:ECXALL="" ECXALL=1 138 S ECXERR=0,ECXP="" 139 ;if ecxall=1, then all pharmacy sites are selected or there's only one 140 I ECXALL=1 S ECXP="" D 141 .F S ECXP=$O(^PS(59,"B",ECXP)) Q:ECXP="" S ECXIEN=$O(^(ECXP,"")) D 142 ..K ECXARR S DIC="^PS(59,",DR=".01;.06;100",DIQ="ECXARR",DA=ECXIEN D EN^DIQ1 143 ..Q:'$D(ECXARR) 144 ..S ECXDIV(ECXIEN)=ECXIEN_U_ECXARR(59,ECXIEN,.01)_U_ECXARR(59,ECXIEN,.06)_U_ECXARR(59,ECXIEN,100) 145 ;if ecxall=0, then user selects pharmacy site(s) 146 I ECXALL=0 S OUT=0 D 147 .F Q:OUT!ECXERR D 148 ..S DIC="^PS(59,",DIC(0)="AEMQZ" K X,Y D ^DIC 149 ..I $G(DUOUT)!($G(DTOUT)) S OUT=1,ECXERR=1 Q 150 ..I Y=-1,X="" S OUT=1 Q 151 ..K ECXARR S (ECXIEN,DA)=+Y,DIC="^PS(59,",DR=".01;.06;100",DIQ="ECXARR" D EN^DIQ1 152 ..Q:'$D(ECXARR) 153 ..S ECXDIV(ECXIEN)=ECXIEN_U_ECXARR(59,ECXIEN,.01)_U_ECXARR(59,ECXIEN,.06)_U_ECXARR(59,ECXIEN,100) 154 ; 155 I ECXERR=1 K ECXDIV 156 I '$D(ECXDIV) S ECXERR=1 157 Q -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXEC.m
r613 r623 1 ECXEC ;ALB/JAP,BIR/JLP,PTD-DSS Event Capture Extract ; 10/2/07 2:33pm 2 ;;3.0;DSS EXTRACTS;**11,8,13,24,27,33,39,46,49,71,89,92,105**;Dec 22, 1997;Build 70 3 BEG ;entry point from option 4 I '$D(^ECH) W !,"Event Capture is not initialized",!! Q 5 D SETUP I ECFILE="" Q 6 D ^ECXTRAC,^ECXKILL 7 Q 8 START ;begin EC extract 9 N X,Y,ECDCM,ECXNPRFI 10 S ECED=ECED+.3,ECLL=0 11 K ^TMP("EC",$J) 12 F S ECLL=$O(^ECH("AC1",ECLL)),ECD=ECSD-.1 Q:'ECLL D 13 .F S ECD=$O(^ECH("AC1",ECLL,ECD)),ECDA=0 Q:(ECD>ECED)!('ECD) D 14 ..F S ECDA=$O(^ECH("AC1",ECLL,ECD,ECDA)) Q:'ECDA D UPDATE 15 Q 16 ; 17 UPDATE ;sets record and updates counters 18 S ECCH=^ECH(ECDA,0),ECL=$P(ECCH,U,4),ECXDFN=$P(ECCH,U,2) 19 S ECXPDIV=$$RADDIV^ECXDEPT(ECL) ;Get production division from file 4 20 S ECDT=$P(ECCH,U,3),ECM=$P(ECCH,U,6),ECC=$P(ECCH,U,8) 21 Q:'$$PATDEM^ECXUTL2(ECXDFN,ECDT,"1;3;5;") 22 S ECTM=$$ECXTIME^ECXUTL(ECDT),ECP=$P(ECCH,U,9) 23 Q:ECP']"" 24 S ECO=$P(ECCH,U,12),ECV=$P(ECCH,U,10),ECDU=$P(ECCH,U,7) 25 S ECXUNIT=$G(^ECD(ECDU,0)),ECCS=+$P(ECXUNIT,U,4),ECDCM=$P(ECXUNIT,U,5) 26 S ECXDSSP="",ECXDSSD=$E(ECDCM,1,10),ECUSTOP=$P(ECXUNIT,U,10),ECUPCE=$P(ECXUNIT,U,14) 27 S ICD9=$P($G(^ECH(ECDA,"P")),U,2) S:ICD9="" ICD9=" " 28 S ECXICD9=$P($G(^ICD9(ICD9,0)),U) 29 F I=1:1:4 S @("ECXICD9"_I)="" 30 S (CNT,I)=0 31 F S CNT=$O(^ECH(ECDA,"DX",CNT)) Q:'CNT D Q:I>3 32 .S ICD9=$P($G(^ECH(ECDA,"DX",CNT,0)),U) D:ICD9'="" 33 ..S I=I+1,@("ECXICD9"_I)=$P($G(^ICD9(ICD9,0)),U) 34 ;derivation of dss identifier depends on whether dss unit is 35 ;set to send data to pce 36 S ECAC=$P($G(ECCH),U,19) 37 ;if this is a record that 'goes to pce', then get the dss identifier 38 ;from the clinic stop codes 39 S (ECAC1S,ECAC2S)="000" 40 I ECUPCE="A"!(ECUPCE="O"&(ECXA="O")) D 41 .D:+ECAC 42 ..S ECAC1=$P($G(^SC(+ECAC,0)),U,7),ECAC2=$P($G(^(0)),U,18) 43 ..I 'ECAC2 S ECAC2S="000" 44 ..I 'ECAC1 S (ECAC1S,ECAC2S)="000" Q 45 ..S ECAC1S=$P($G(^DIC(40.7,+ECAC1,0)),U,2) 46 ..S ECAC2S=$P($G(^DIC(40.7,+ECAC2,0)),U,2) 47 ..S ECAC1S=$$RJ^XLFSTR(ECAC1S,3,0),ECAC2S=$$RJ^XLFSTR(ECAC2S,3,0) 48 .S:'ECAC (ECAC1S,ECAC2S)="000" 49 ;if this record doesn't go to pce, then get the dss identifier 50 ;from the dss unit 51 I ECUPCE=""!(ECUPCE="N")!(ECUPCE="O"&(ECXA="I")) D 52 .I +ECUSTOP D 53 ..S ECAC1S=$P($G(^DIC(40.7,+ECUSTOP,0)),U,2) 54 ..S ECAC1S=$$RJ^XLFSTR(ECAC1S,3,0),ECAC2S="000" 55 .I 'ECUSTOP D 56 ..S (ECAC1S,ECAC2S)="000" 57 S ECDSS=ECAC1S_ECAC2S 58 I ECXLOGIC>2003 I "^18^23^24^36^41^65^94^"[("^"_ECXTS_"^") S ECDSS=$$TSMAP^ECXUTL4(ECXTS) 59 S ECXDIV="" 60 ; 61 ;- Ord Div, Contrct St/End Dates, Contrct Type placeholders for FY2002 62 S (ECXODIV,ECXCSDT,ECXCEDT,ECXCTYP)="" 63 ;setup provider(s) as'2'_ien 64 S (ECU1A,ECU2A,ECU3A,ECU1NPI,ECU2NPI,ECU3NPI,ECXPPC1,ECXPPC2,ECXPPC3)="" 65 S (ECU1,ECU2,ECU3)="" 66 K ECXPRV S ECXPROV=$$GETPRV^ECPRVMUT(ECDA,.ECXPRV) I ECXPROV Q 67 F I=1:1:3 S Y=$O(ECXPRV("")) I Y'="" S @("ECU"_I)=+ECXPRV(Y) K ECXPRV(Y) 68 S:$L(ECU1) ECXPPC1=$$PRVCLASS^ECXUTL(ECU1,ECDT),ECU1A="2"_$P(ECU1,";") 69 S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",ECU1,ECDT) 70 S:+ECXUSRTN'>0 ECXUSRTN="" S ECU1NPI=$P(ECXUSRTN,U) 71 S:$L(ECU2) ECXPPC2=$$PRVCLASS^ECXUTL(ECU2,ECDT),ECU2A="2"_$P(ECU2,";") 72 S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",ECU2,ECDT) 73 S:+ECXUSRTN'>0 ECXUSRTN="" S ECU2NPI=$P(ECXUSRTN,U) 74 S:$L(ECU3) ECXPPC3=$$PRVCLASS^ECXUTL(ECU3,ECDT),ECU3A="2"_$P(ECU3,";") 75 S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",ECU3,ECDT) 76 S:+ECXUSRTN'>0 ECXUSRTN="" S ECU3NPI=$P(ECXUSRTN,U) 77 ;change for version 2 where ECP is a variable pointer and we want to 78 ;expand it category = category or null if stored as 0 79 D:ECP[";" 80 .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:"") 81 ;pick up EC to PCE data from "P" in File 721 82 S ECPCE=$G(^ECH(ECDA,"P")),ECPCE1=$P(ECPCE,U),ECPCE2=$P(ECPCE,U,2) 83 S ECPCE7=$S($P(ECPCE,U,7)=1:"Y",1:"N") 84 S ECXCMOD="" 85 I $D(^ECH(ECDA,"MOD")) D 86 .S MOD=0,M="" 87 .F S MOD=$O(^ECH(ECDA,"MOD",MOD)) Q:'MOD S M=$P(^(MOD,0),U) D 88 ..I M S ECXCMOD=ECXCMOD_M_";" 89 .K MOD,M 90 S:ECP?1.N ECP=$$CPT^ECXUTL3($E(ECP,1,5),"",ECV) 91 S ECXCPT=$$CPT^ECXUTL3(ECPCE1,ECXCMOD,ECV) 92 ; 93 ;- Observation Patient Indicator (YES/NO) 94 S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECDSS) 95 ; 96 ;- CNH status (YES/NO) 97 S ECXCNH=$$CNHSTAT^ECXUTL4(ECXDFN) 98 ; 99 ;- encounter classification 100 S (ECXAO,ECXECE,ECXHNC,ECXMIL,ECXIR)="",ECXVISIT=$P(ECCH,U,21) 101 I ECXVISIT'="" D 102 .D VISIT^ECXSCX1(ECXDFN,ECXVISIT,.ECXVIST,.ECXERR) I ECXERR K ECXERR Q 103 .S ECXAO=$G(ECXVIST("AO")),ECXECE=$G(ECXVIST("PGE")) 104 .S ECXHNC=$G(ECXVIST("HNC")),ECXMIL=$G(ECXVIST("MST")),ECXIR=$G(ECXVIST("IR")) 105 ; - Head and Neck Cancer Indicator 106 S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) 107 ; 108 ; - Get national patient record flag Indicator if exist 109 D NPRF^ECXUTL5 110 ; 111 ; - If no encounter number don't file record 112 S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECDT,ECXTS,ECXOBS,ECHEAD,ECDSS,ECCS) 113 D:ECXENC'="" FILE 114 Q 115 ; 116 FILE ;file record in #727.815 117 ;node0 118 ;ecode=inst ECL^dfn ECXDFN^ssn ECXSSN^name ECXPNM^i/o status ECXA^day^ 119 ;DSS unit ECDU^category ECC^procedure ECP^volume ECV^ 120 ;cost center ECCS^ordering sec ECO^section ECM^ 121 ;provider ECU1A^prov per cls ECXPPC1^prov 2 ECU2A^prov#2 per cls ECXPPC2 122 ;^prov 3 ECU3A^prov#3 per cls ECXPPC3^^mov # ECXMN^treat spec ECXTS 123 ;^time ECTM^primary care team ECPTTM^primary care provider ECPTPR 124 ;^pce cpt code (ECXCPT)^primary icd-9 code ECXICD9^secondary icd-9 125 ;ECXICD91^secondary icd-9 ECXICD92^secondary icd-9 ECXICD93^secondary 126 ;icd-9 ECXICD94^agent orange ECXAST^radiation exposure ECXRST^ 127 ;environmental contaminants ECXEST^service connected ECPTPR^sent to pce 128 ;ECPCE7^^dss identifier ECDSS^dss dept 129 ;node1 130 ;mpi ECXMPI^dss dept ECXDSSD^PLACEHOLDER 131 ;placeholder^placeholder^placeholder^ 132 ;placeholder^pc prov person class ECCLAS^ 133 ;assoc pc prov ECASPR^assoc pc prov person class ECCLAS2^ 134 ;placeholder^ 135 ;divison ECXDIV^mst status ECXMST^dom ECXDOM^date of birth ECXDOB^ 136 ;enrollment category ECXCAT^ enrollment status ECXSTAT^enrollment 137 ;priority ECXPRIOR^period of service ECXPOS^purple heart indicator 138 ;ECXPHI^observ pat ind ECXOBS^encounter num ECXENC^ 139 ;ao loc ECXAOL^ord div ECXODIV^contr st dt ECXCSDT^ 140 ;contr end dt ECXCEDT^contr typ ECXCTYP^CNH stat ECXCNH^ 141 ;production division ECXPDIV^eligibility ECXELIG^ 142 ;head & neck cancer ind. ECXHNCI^ethnicity ECXETH^race1 ECXRAC1 143 ;enrollment location ECXENRL^^enrollment priority 144 ;ECXPRIOR_enrollment subgroup ECXSBGRP^user enrollee ECXUESTA^patient 145 ;type ECXPTYPE^combat vet elig ECXCVE^combat vet elig end date 146 ;ECXCVEDT^enc cv eligible ECXCVENC^national patient record flag 147 ;ECXNPRFI^emerg response indic(FEMA) ECXERI^agent orange indic ECXAO^ 148 ;environ contam ECXECE^head/neck cancer ECXHNC^encntr mst ECXMIL 149 ;^radiation ECXIR^OEF/OIF ECXOEF^OEF/OIF return date ECXOEFDT 150 ;^associate pc provider npi ECASNPI^primary care provider npi ECPTNPI^ 151 ;provider npi ECU1NPI^provider #2 ECU2NPI^provider #3 ECU3NPI 152 N DA,DIK 153 S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 154 S ECODE=EC7_U_EC23_U_ECL_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U 155 S ECODE=ECODE_$$ECXDATE^ECXUTL(ECDT,ECXYM)_U_ECDU_U_ECC_U 156 S ECODE=ECODE_ECP_U_ECV_U_ECCS_U_ECO_U_ECM_U_ECU1A_U_ECXPPC1_U 157 S ECODE=ECODE_ECU2A_U_ECXPPC2_U_ECU3A_U_ECXPPC3_U_U_ECXMN_U 158 S ECODE=ECODE_ECXTS_U_ECTM_U 159 S ECODE=ECODE_ECPTTM_U_ECPTPR_U_ECXCPT_U_ECXICD9_U 160 S ECODE=ECODE_ECXICD91_U_ECXICD92_U_ECXICD93_U 161 S ECODE=ECODE_ECXICD94_U_ECXAST_U_ECXRST_U_ECXEST_U 162 S ECODE=ECODE_ECSC_U_ECPCE7_U_U_ECDSS_U_U 163 S ECODE1=ECXMPI_U_ECXDSSD_U_U_U_U_ECCLAS_U 164 S ECODE1=ECODE1_U_ECASPR_U_ECCLAS2_U_U_ECXDIV_U 165 S ECODE1=ECODE1_ECXMST_U_ECXDOM_U_ECXDOB_U_ECXCAT_U_ECXSTAT_U 166 S ECODE1=ECODE1_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXPOS_U_ECXPHI_U_ECXOBS_U_ECXENC_U_ECXAOL_U 167 S ECODE1=ECODE1_ECXODIV_U_ECXCSDT_U_ECXCEDT_U_ECXCTYP_U_ECXCNH_U_ECXPDIV_U 168 S ECODE1=ECODE1_ECXELIG_U_ECXHNCI_U_ECXETH_U_ECXRC1 169 I ECXLOGIC>2003 S ECODE1=ECODE1_U_ECXENRL_U 170 I ECXLOGIC>2004 S ECODE1=ECODE1_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U 171 I ECXLOGIC>2004 S ECODE2=ECXCVEDT_U_ECXCVENC_U_ECXNPRFI 172 I ECXLOGIC>2006 S ECODE2=ECODE2_U_ECXERI_U_ECXAO_U_ECXECE_U_ECXHNC_U_ECXMIL_U_ECXIR_U 173 I ECXLOGIC>2007 S ECODE2=ECODE2_U_ECXOEF_U_ECXOEFDT_U_ECASNPI_U_ECPTNPI_U_ECU1NPI_U_ECU2NPI_U_ECU3NPI 174 S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,^ECX(ECFILE,EC7,2)=$G(ECODE2),ECRN=ECRN+1 175 S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA 176 I $D(ZTQUEUED),$$S^%ZTLOAD 177 Q 178 ; 179 SETUP ;Set required input for ECXTRAC 180 S ECHEAD="ECS" 181 D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) 182 Q 183 ; 184 QUE ; entry point for the background requeuing handled by ECXTAUTO 185 D SETUP,QUE^ECXTAUTO,^ECXKILL Q 1 ECXEC ;ALB/JAP,BIR/JLP,PTD-DSS Event Capture Extract [ 02/14/97 2:26 PM ] ; 12/2/04 12:35pm 2 ;;3.0;DSS EXTRACTS;**11,8,13,24,27,33,39,46,49,71,89,92**;Dec 22, 1997;Build 30 3 BEG ;entry point from option 4 I '$D(^ECH) W !,"Event Capture is not initialized",!! Q 5 D SETUP I ECFILE="" Q 6 D ^ECXTRAC,^ECXKILL 7 Q 8 START ;begin EC extract 9 N X,Y,ECDCM,ECXNPRFI 10 S ECED=ECED+.3,ECLL=0 11 K ^TMP("EC",$J) 12 F S ECLL=$O(^ECH("AC1",ECLL)),ECD=ECSD-.1 Q:'ECLL D 13 .F S ECD=$O(^ECH("AC1",ECLL,ECD)),ECDA=0 Q:(ECD>ECED)!('ECD) D 14 ..F S ECDA=$O(^ECH("AC1",ECLL,ECD,ECDA)) Q:'ECDA D UPDATE 15 Q 16 ; 17 UPDATE ;sets record and updates counters 18 S ECCH=^ECH(ECDA,0),ECL=$P(ECCH,U,4),ECXDFN=$P(ECCH,U,2) 19 S ECXPDIV=$$RADDIV^ECXDEPT(ECL) ;Get production division from file 4 20 S ECDT=$P(ECCH,U,3),ECM=$P(ECCH,U,6),ECC=$P(ECCH,U,8) 21 Q:'$$PATDEM^ECXUTL2(ECXDFN,ECDT,"1;3;5;") 22 S ECTM=$$ECXTIME^ECXUTL(ECDT),ECP=$P(ECCH,U,9) 23 Q:ECP']"" 24 S ECO=$P(ECCH,U,12),ECV=$P(ECCH,U,10),ECDU=$P(ECCH,U,7) 25 S ECXUNIT=$G(^ECD(ECDU,0)),ECCS=+$P(ECXUNIT,U,4),ECDCM=$P(ECXUNIT,U,5) 26 S ECXDSSP="",ECXDSSD=$E(ECDCM,1,10),ECUSTOP=$P(ECXUNIT,U,10),ECUPCE=$P(ECXUNIT,U,14) 27 S ICD9=$P($G(^ECH(ECDA,"P")),U,2) S:ICD9="" ICD9=" " 28 S ECXICD9=$P($G(^ICD9(ICD9,0)),U) 29 F I=1:1:4 S @("ECXICD9"_I)="" 30 S (CNT,I)=0 31 F S CNT=$O(^ECH(ECDA,"DX",CNT)) Q:'CNT D Q:I>3 32 .S ICD9=$P($G(^ECH(ECDA,"DX",CNT,0)),U) D:ICD9'="" 33 ..S I=I+1,@("ECXICD9"_I)=$P($G(^ICD9(ICD9,0)),U) 34 ;derivation of dss identifier depends on whether dss unit is 35 ;set to send data to pce 36 S ECAC=$P($G(ECCH),U,19) 37 ;if this is a record that 'goes to pce', then get the dss identifier 38 ;from the clinic stop codes 39 S (ECAC1S,ECAC2S)="000" 40 I ECUPCE="A"!(ECUPCE="O"&(ECXA="O")) D 41 .D:+ECAC 42 ..S ECAC1=$P($G(^SC(+ECAC,0)),U,7),ECAC2=$P($G(^(0)),U,18) 43 ..I 'ECAC2 S ECAC2S="000" 44 ..I 'ECAC1 S (ECAC1S,ECAC2S)="000" Q 45 ..S ECAC1S=$P($G(^DIC(40.7,+ECAC1,0)),U,2) 46 ..S ECAC2S=$P($G(^DIC(40.7,+ECAC2,0)),U,2) 47 ..S ECAC1S=$$RJ^XLFSTR(ECAC1S,3,0),ECAC2S=$$RJ^XLFSTR(ECAC2S,3,0) 48 .S:'ECAC (ECAC1S,ECAC2S)="000" 49 ;if this record doesn't go to pce, then get the dss identifier 50 ;from the dss unit 51 I ECUPCE=""!(ECUPCE="N")!(ECUPCE="O"&(ECXA="I")) D 52 .I +ECUSTOP D 53 ..S ECAC1S=$P($G(^DIC(40.7,+ECUSTOP,0)),U,2) 54 ..S ECAC1S=$$RJ^XLFSTR(ECAC1S,3,0),ECAC2S="000" 55 .I 'ECUSTOP D 56 ..S (ECAC1S,ECAC2S)="000" 57 S ECDSS=ECAC1S_ECAC2S 58 I ECXLOGIC>2003 I "^18^23^24^36^41^65^94^"[("^"_ECXTS_"^") S ECDSS=$$TSMAP^ECXUTL4(ECXTS) 59 S ECXDIV="" 60 ; 61 ;- Ord Div, Contrct St/End Dates, Contrct Type placeholders for FY2002 62 S (ECXODIV,ECXCSDT,ECXCEDT,ECXCTYP)="" 63 ;setup provider(s) as'2'_ien 64 S (ECU1A,ECU2A,ECU3A,ECU1NPI,ECU2NPI,ECU3NPI,ECXPPC1,ECXPPC2,ECXPPC3)="" 65 S (ECU1,ECU2,ECU3)="" 66 K ECXPRV S ECXPROV=$$GETPRV^ECPRVMUT(ECDA,.ECXPRV) I ECXPROV Q 67 F I=1:1:3 S Y=$O(ECXPRV("")) I Y'="" S @("ECU"_I)=+ECXPRV(Y) K ECXPRV(Y) 68 S:$L(ECU1) ECXPPC1=$$PRVCLASS^ECXUTL(ECU1,ECDT),ECU1A="2"_$P(ECU1,";") 69 S:$L(ECU2) ECXPPC2=$$PRVCLASS^ECXUTL(ECU2,ECDT),ECU2A="2"_$P(ECU2,";") 70 S:$L(ECU3) ECXPPC3=$$PRVCLASS^ECXUTL(ECU3,ECDT),ECU3A="2"_$P(ECU3,";") 71 ;change for version 2 where ECP is a variable pointer and we want to 72 ;expand it category = category or null if stored as 0 73 D:ECP[";" 74 .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:"") 75 ;pick up EC to PCE data from "P" in File 721 76 S ECPCE=$G(^ECH(ECDA,"P")),ECPCE1=$P(ECPCE,U),ECPCE2=$P(ECPCE,U,2) 77 S ECPCE7=$S($P(ECPCE,U,7)=1:"Y",1:"N") 78 S ECXCMOD="" 79 I $D(^ECH(ECDA,"MOD")) D 80 .S MOD=0,M="" 81 .F S MOD=$O(^ECH(ECDA,"MOD",MOD)) Q:'MOD S M=$P(^(MOD,0),U) D 82 ..I M S ECXCMOD=ECXCMOD_M_";" 83 .K MOD,M 84 S:ECP?1.N ECP=$$CPT^ECXUTL3($E(ECP,1,5),"",ECV) 85 S ECXCPT=$$CPT^ECXUTL3(ECPCE1,ECXCMOD,ECV) 86 ; 87 ;- Observation Patient Indicator (YES/NO) 88 S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECDSS) 89 ; 90 ;- CNH status (YES/NO) 91 S ECXCNH=$$CNHSTAT^ECXUTL4(ECXDFN) 92 ; 93 ;- encounter classification 94 S (ECXAO,ECXECE,ECXHNC,ECXMIL,ECXIR)="",ECXVISIT=$P(ECCH,U,21) 95 I ECXVISIT'="" D 96 .D VISIT^ECXSCX1(ECXDFN,ECXVISIT,.ECXVIST,.ECXERR) I ECXERR K ECXERR Q 97 .S ECXAO=$G(ECXVIST("AO")),ECXECE=$G(ECXVIST("PGE")) 98 .S ECXHNC=$G(ECXVIST("HNC")),ECXMIL=$G(ECXVIST("MST")),ECXIR=$G(ECXVIST("IR")) 99 ; - Head and Neck Cancer Indicator 100 S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) 101 ; 102 ; - Get national patient record flag Indicator if exist 103 D NPRF^ECXUTL5 104 ; 105 ; - If no encounter number don't file record 106 S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECDT,ECXTS,ECXOBS,ECHEAD,ECDSS,ECCS) 107 D:ECXENC'="" FILE 108 Q 109 ; 110 FILE ;file record in #727.815 111 ;node0 112 ;ecode=inst ECL^dfn ECXDFN^ssn ECXSSN^name ECXPNM^i/o status ECXA^day^ 113 ;DSS unit ECDU^category ECC^procedure ECP^volume ECV^ 114 ;cost center ECCS^ordering sec ECO^section ECM^ 115 ;provider ECU1A^prov per cls ECXPPC1^prov 2 ECU2A^prov#2 per cls ECXPPC2 116 ;^prov 3 ECU3A^prov#3 per cls ECXPPC3^^mov # ECXMN^treat spec ECXTS 117 ;^time ECTM^primary care team ECPTTM^primary care provider ECPTPR 118 ;^pce cpt code (ECXCPT)^primary icd-9 code ECXICD9^secondary icd-9 119 ;ECXICD91^secondary icd-9 ECXICD92^secondary icd-9 ECXICD93^secondary 120 ;icd-9 ECXICD94^agent orange ECXAST^radiation exposure ECXRST^ 121 ;environmental contaminants ECXEST^service connected ECPTPR^sent to pce 122 ;ECPCE7^^dss identifier ECDSS^dss dept 123 ;node1 124 ;mpi ECXMPI^dss dept ECXDSSD^provider npi ECXPRV2^ 125 ;provider #2 npi ECU2NPI^provider #3 npi ECU3NPI^^ 126 ;pc provider npi ECPTNPI^pc prov person class ECCLAS^ 127 ;assoc pc prov ECASPR^assoc pc prov person class ECCLAS2^ 128 ;assoc pc prov npi ECASNPI^ 129 ;divison ECXDIV^mst status ECXMST^dom ECXDOM^date of birth ECXDOB^ 130 ;enrollment category ECXCAT^ enrollment status ECXSTAT^enrollment 131 ;priority ECXPRIOR^period of service ECXPOS^purple heart indicator 132 ;ECXPHI^observ pat ind ECXOBS^encounter num ECXENC^ 133 ;ao loc ECXAOL^ord div ECXODIV^contr st dt ECXCSDT^ 134 ;contr end dt ECXCEDT^contr typ ECXCTYP^CNH stat ECXCNH^ 135 ;production division ECXPDIV^eligibility ECXELIG^ 136 ;head & neck cancer ind. ECXHNCI^ethnicity ECXETH^race1 ECXRAC1 137 ;enrollment location ECXENRL^^enrollment priority 138 ;ECXPRIOR_enrollment subgroup ECXSBGRP^user enrollee ECXUESTA^patient 139 ;type ECXPTYPE^combat vet elig ECXCVE^combat vet elig end date 140 ;ECXCVEDT^enc cv eligible ECXCVENC^national patient record flag 141 ;ECXNPRFI^emerg response indic(FEMA) ECXERI^agent orange indic ECXAO^ 142 ;environ contam ECXECE^head/neck cancer ECXHNC^encntr mst ECXMIL 143 ;^radiation ECXIR 144 N DA,DIK 145 S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 146 S ECODE=EC7_U_EC23_U_ECL_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U 147 S ECODE=ECODE_$$ECXDATE^ECXUTL(ECDT,ECXYM)_U_ECDU_U_ECC_U 148 S ECODE=ECODE_ECP_U_ECV_U_ECCS_U_ECO_U_ECM_U_ECU1A_U_ECXPPC1_U 149 S ECODE=ECODE_ECU2A_U_ECXPPC2_U_ECU3A_U_ECXPPC3_U_U_ECXMN_U 150 S ECODE=ECODE_ECXTS_U_ECTM_U 151 S ECODE=ECODE_ECPTTM_U_ECPTPR_U_ECXCPT_U_ECXICD9_U 152 S ECODE=ECODE_ECXICD91_U_ECXICD92_U_ECXICD93_U 153 S ECODE=ECODE_ECXICD94_U_ECXAST_U_ECXRST_U_ECXEST_U 154 S ECODE=ECODE_ECSC_U_ECPCE7_U_U_ECDSS_U_U 155 S ECODE1=ECXMPI_U_ECXDSSD_U_ECU1NPI_U_ECU2NPI_U_ECU3NPI_U_ECCLAS_U 156 S ECODE1=ECODE1_ECPTNPI_U_ECASPR_U_ECCLAS2_U_ECASNPI_U_ECXDIV_U 157 S ECODE1=ECODE1_ECXMST_U_ECXDOM_U_ECXDOB_U_ECXCAT_U_ECXSTAT_U 158 S ECODE1=ECODE1_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXPOS_U_ECXPHI_U_ECXOBS_U_ECXENC_U_ECXAOL_U 159 S ECODE1=ECODE1_ECXODIV_U_ECXCSDT_U_ECXCEDT_U_ECXCTYP_U_ECXCNH_U_ECXPDIV_U 160 S ECODE1=ECODE1_ECXELIG_U_ECXHNCI_U_ECXETH_U_ECXRC1 161 I ECXLOGIC>2003 S ECODE1=ECODE1_U_ECXENRL_U 162 I ECXLOGIC>2004 S ECODE1=ECODE1_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U 163 I ECXLOGIC>2004 S ECODE2=ECXCVEDT_U_ECXCVENC_U_ECXNPRFI 164 I ECXLOGIC>2006 S ECODE2=ECODE2_U_ECXERI_U_ECXAO_U_ECXECE_U_ECXHNC_U_ECXMIL_U_ECXIR_U 165 S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,^ECX(ECFILE,EC7,2)=$G(ECODE2),ECRN=ECRN+1 166 S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA 167 I $D(ZTQUEUED),$$S^%ZTLOAD 168 Q 169 ; 170 SETUP ;Set required input for ECXTRAC 171 S ECHEAD="ECS" 172 D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) 173 Q 174 ; 175 QUE ; entry point for the background requeuing handled by ECXTAUTO 176 D SETUP,QUE^ECXTAUTO,^ECXKILL Q -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXFELOC.m
r613 r623 1 ECXFELOC ;BIR/DMA,CML-Print Feeder Locations; [ 05/07/96 8:41 AM ] ; 6/12/07 6:29am 2 ;;3.0;DSS EXTRACTS;**1,8,105**;Dec 22, 1997;Build 70 3 EN ;entry point from option 4 W !!,"Print list of feeder locations.",! S QFLG=1 5 K %ZIS S %ZIS="Q" D ^%ZIS Q:POP 6 I $D(IO("Q")) S ZTDESC="Feeder Location List (DSS)",ZTRTN="START^ECXFELOC" D ^%ZTLOAD D ^%ZISC G OUT 7 U IO 8 START ;queued entry point 9 I '$D(DT) S DT=$$HTFM^XLFDT(+$H) 10 K ^TMP($J) S (QFLG,PG)=0,$P(LN,"-",81)="" 11 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) 12 ECS S EC=0 I $P($G(^EC(720.1,1,0)),U,2) D G IV 13 .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 14 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 15 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 16 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 17 .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&(RD<DT)) S ^TMP($J,"CLI",ECS_ECSC,EC)=ECD 18 PRE N ARRAY S ARRAY="^TMP($J,""ECXDSS"")" K @ARRAY D PSS^PSO59(,"??","ECXDSS") I @ARRAY@(0)>0 G V6 19 ;dbia (#4689) 20 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 21 G RAD 22 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 23 K @ARRAY 24 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 25 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 26 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 27 1 ;;ORGE^GENERAL PURPOSE OPERATING ROOM 28 2 ;;OROR^ORTHOPEDIC OPERATING ROOM 29 3 ;;ORCA^CARDIAC OPERATING ROOM 30 4 ;;ORNE^NEUROSURGERY OPERATING ROOM 31 5 ;;ORCN^CARDIAC/NEURO OPERATING ROOM 32 6 ;;ORAM^AMBULATORY OPERATING ROOM 33 7 ;;ORIN^INTENSIVE CARE UNIT 34 8 ;;OREN^ENDOSCOPY ROOM 35 9 ;;ORCY^CYSTOSCOPY ROOM 36 10 ;;ORWA^WARD 37 11 ;;ORCL^CLINIC 38 12 ;;ORDE^DEDICATED ROOM 39 13 ;;OROT^OTHER LOCATION 40 14 ;;ORNO^UNKNOWN 41 I ;;IMPLANTS 42 A ;;ANESTHESIA TIME 43 D ;;SURGERY TIME (DENTAL) 44 M ;;SURGERY TIME (MEDICINE) 45 P ;;SURGERY TIME (PSYCH) 46 C ;;SURGERY TIME (SPINAL CORD) 47 S ;;SURGERY TIME (SURGERY) 48 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 49 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 50 ; 51 PRINT ; 52 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 53 .W !,?5,EC1,?23,^(EC2) I $Y+3>IOSL D HEAD Q:QFLG 54 OUT I $E(IOST)="C"&('QFLG) S DIR(0)="E" D D ^DIR K DIR 55 .S SS=22-$Y F JJ=1:1:SS W ! 56 K ^TMP($J),DAT,EC,EC1,EC2,EC3,ECD,ECD1,ECS,ECSC,ID,JJ,LN,PG,POP,QFLG,RD,SS,X,Y 57 W:$E(IOST)'="C" @IOF D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" Q 58 HEAD ; 59 I $E(IOST)="C" S SS=22-$Y F JJ=1:1:SS W ! 60 I $E(IOST)="C",PG>0 S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q 61 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 62 Q 1 ECXFELOC ;BIR/DMA,CML-Print Feeder Locations; [ 05/07/96 8:41 AM ] 2 ;;3.0;DSS EXTRACTS;**1,8**;Dec 22, 1997 3 EN ;entry point from option 4 W !!,"Print list of feeder locations.",! S QFLG=1 5 K %ZIS S %ZIS="Q" D ^%ZIS Q:POP 6 I $D(IO("Q")) S ZTDESC="Feeder Location List (DSS)",ZTRTN="START^ECXFELOC" D ^%ZTLOAD D ^%ZISC G OUT 7 U IO 8 START ;queued entry point 9 I '$D(DT) S DT=$$HTFM^XLFDT(+$H) 10 K ^TMP($J) S (QFLG,PG)=0,$P(LN,"-",81)="" 11 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) 12 ECS S EC=0 I $P($G(^EC(720.1,1,0)),U,2) D G IV 13 .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 14 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 15 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 16 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 17 .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&(RD<DT)) S ^TMP($J,"CLI",ECS_ECSC,EC)=ECD 18 PRE I $O(^PS(59,0)) G V6 19 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 20 G RAD 21 V6 S EC=0 F S EC=$O(^PS(59,EC)) Q:'EC I $D(^(EC,0)) S EC1=$E($P(^(0),U),1,30),^TMP($J,"PRE","PRE"_EC,EC)="Prescriptions-"_EC1 22 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 23 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 24 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 25 1 ;;ORGE^GENERAL PURPOSE OPERATING ROOM 26 2 ;;OROR^ORTHOPEDIC OPERATING ROOM 27 3 ;;ORCA^CARDIAC OPERATING ROOM 28 4 ;;ORNE^NEUROSURGERY OPERATING ROOM 29 5 ;;ORCN^CARDIAC/NEURO OPERATING ROOM 30 6 ;;ORAM^AMBULATORY OPERATING ROOM 31 7 ;;ORIN^INTENSIVE CARE UNIT 32 8 ;;OREN^ENDOSCOPY ROOM 33 9 ;;ORCY^CYSTOSCOPY ROOM 34 10 ;;ORWA^WARD 35 11 ;;ORCL^CLINIC 36 12 ;;ORDE^DEDICATED ROOM 37 13 ;;OROT^OTHER LOCATION 38 14 ;;ORNO^UNKNOWN 39 I ;;IMPLANTS 40 A ;;ANESTHESIA TIME 41 D ;;SURGERY TIME (DENTAL) 42 M ;;SURGERY TIME (MEDICINE) 43 P ;;SURGERY TIME (PSYCH) 44 C ;;SURGERY TIME (SPINAL CORD) 45 S ;;SURGERY TIME (SURGERY) 46 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 47 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 48 ; 49 PRINT ; 50 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 51 .W !,?5,EC1,?23,^(EC2) I $Y+3>IOSL D HEAD Q:QFLG 52 OUT I $E(IOST)="C"&('QFLG) S DIR(0)="E" D D ^DIR K DIR 53 .S SS=22-$Y F JJ=1:1:SS W ! 54 K ^TMP($J),DAT,EC,EC1,EC2,EC3,ECD,ECD1,ECS,ECSC,ID,JJ,LN,PG,POP,QFLG,RD,SS,X,Y 55 W:$E(IOST)'="C" @IOF D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" Q 56 HEAD ; 57 I $E(IOST)="C" S SS=22-$Y F JJ=1:1:SS W ! 58 I $E(IOST)="C",PG>0 S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q 59 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 60 Q -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXKILL.m
r613 r623 1 ECXKILL ;BIR/DMA,PTD-Kill Local Variables ; 5/30/2007 2 ;;3.0;DSS EXTRACTS;**9,8,21,24,31,39,49,84,89,92,105**;Dec 22, 1997;Build 70 3 ; 4 K %,%DT,%Y,%ZIS,A,A1,A2,ABR,B,BY,D,D0,D1,DA,DAT,DATA,DATA1,DATA2,DATA6 5 K DATAOP,DD,DFN,DHDH,DIC,DIE,DIK,DINUM,DIQ 6 K ECDAPRNP,ECDPRNPI,ECISNPI,ECDOCNPI 7 K ECU1NPI,ECU2NPI,ECU3NPI 8 K DIR,DIRUT,DO,DR,DTOUT,DUOUT,EC,EC0,EC1,EC10,EC11,EC16,EC2,EC23,EC2NODE 9 K EC3,EC42,EC50,EC6,EC7,ECA,ECAC,ECACA,ECAD,ECADM,ECALL 10 K ECANE,ECAO,ECARG,ECAS,ECAT,ECATSV,ECB,ECC,ECCA,ECCAN,ECCAT,ECCH,ECCN 11 K ECCNT,ECCS,ECCSC,ECD,ECD0,ECD1,ECDA,ECDAL,ECDAT 12 K ECDATA,ECDATA1,ECDATE,ECDEN,ECDEX,ECDF,ECDFN,ECDFN0,ECDI,ECDIA,ECDIF 13 K ECDIV,ECDL,ECDN,ECDNEW,ECDO,ECDOC,ECDR,ECDRG,ECDS,ECDSSU,ECDT,ECDTTM 14 K ECDU,ECEC0,ECED,ECED1,ECEDN,ECEDNEW,ECF,ECF1,ECFD,ECFDT,ECFILE,ECFK 15 K ECFL,ECFR,ECGRP,ECH,ECHD,ECHEAD,ECI,ECID,ECIEN,ECIFN,ECIN 16 K ECINST,ECINV,ECIV,ECJ,ECK,ECL,ECL1,ECLAN,ECLAST,ECLDT,ECLINK,ECLIST 17 K ECLL,ECLN,ECLOC,ECLRN,ECLX,ECLY,ECM,ECMAX,ECMIN 18 K ECXMISS,ECMN,ECMOD,ECMODS,ECMORE,ECMS,ECMSG,ECMSN,ECMT,ECMW,ECMY,ECN 19 K ECNA,ECNDC,ECNDF,ECNFC,ECNL,ECNO,ECNODE,ECNOGO 20 K ECNT,ECO,ECO0,ECO1,ECO2,ECOB,ECODE,ECODE0,ECODE1,ECODE2,ECOLD,ECONE,ECOPAY 21 K ECATTNPI,ECPWNPI,ECXUSNPI,ECPWNPI,ECXOEF,ECXOEFDT,ECPLACE 22 K ECOPAYT,ECORTY,ECOS,ECP,ECPACK,ECPCE,ECPCE1,ECPCE2,ECPCE3,ECPCE4 23 K ECPCE5,ECPCE6,ECPCE7,ECPIECE,ECPN,ECPRC,ECPRO,ECODE2 24 K ECPROF,ECPT,ECPTF,ECPTPR,ECPTTM,ECQ,ECQT,ECQTY,ECRD,ECRE,ECRED,ECREF 25 K ECRFL,ECRN,ECROU,ECRR,ECRS,ECRSD,ECRTN,ECRX,ECS,ECSA,ECSC 26 K ECSD,ECSD1,ECSDN,ECSN,ECSR,ECSS,ECST,ECSTOP,ECSU,ECT,ECT1,ECTD,ECTD1 27 K ECTEMP,ECTM,ECTNTL,ECTOTAL,ECTREAT,ECTRT,ECTS,ECTY,ECXLOGIC,ECXDATES,ECXEST,ECXECE 28 D ^ECXKILL1 29 ; 30 AUDIT ;kill audit report variables, close slave printer 31 K %DT,ECX,ECXARRAY,ECXACC,ECXALL,ECXAUD,ECXCODE,ECXD,ECXDEF,ECXDESC,ECXDIV 32 K ECXRCST,ECXRQST,ECXEND,ECXERR,ECXEXT,ECXHEAD,ECXLOC,ECXPGM,ECXPHCPC 33 K ECXPRIME,ECXPRO,ECXREPT,ECXRUN,ECXSAVE,ECXSTART,ECXSRCE 34 K ECXCTAMT,ECXFEKEY,ECXFELOC,ECXFORM,ECXGRPR,ECXHCPC,ECXPHCPC,ECXHCPCS 35 K ECXLAB,ECXLLC,ECXLMC,ECXQTY,ECXREQ,ECXSTAT,ECXTYPE 36 K IO("Q"),POP,DIR,DIC,DIE,DA,DR,DO,DIRUT,DUOUT,DTOUT 37 K ^TMP($J) 38 I IO=IO(0),IOST'="C" D ^%ZISC 39 Q 1 ECXKILL ;BIR/DMA,PTD-Kill Local Variables ; 9/13/05 10:24am 2 ;;3.0;DSS EXTRACTS;**9,8,21,24,31,39,49,84,89**;Dec 22, 1997 3 ; 4 K %,%DT,%Y,%ZIS,A,A1,A2,ABR,B,BY,D,D0,D1,DA,DAT,DATA,DATA1,DATA2,DATA6 5 K DATAOP,DD,DFN,DHDH,DIC,DIE,DIK,DINUM,DIQ 6 K DIR,DIRUT,DO,DR,DTOUT,DUOUT,EC,EC0,EC1,EC10,EC11,EC16,EC2,EC23,EC2NODE 7 K EC3,EC42,EC50,EC6,EC7,ECA,ECAC,ECACA,ECAD,ECADM,ECALL 8 K ECANE,ECAO,ECARG,ECAS,ECAT,ECATSV,ECB,ECC,ECCA,ECCAN,ECCAT,ECCH,ECCN 9 K ECCNT,ECCS,ECCSC,ECD,ECD0,ECD1,ECDA,ECDAL,ECDAT 10 K ECDATA,ECDATA1,ECDATE,ECDEN,ECDEX,ECDF,ECDFN,ECDFN0,ECDI,ECDIA,ECDIF 11 K ECDIV,ECDL,ECDN,ECDNEW,ECDO,ECDOC,ECDR,ECDRG,ECDS,ECDSSU,ECDT,ECDTTM 12 K ECDU,ECEC0,ECED,ECED1,ECEDN,ECEDNEW,ECF,ECF1,ECFD,ECFDT,ECFILE,ECFK 13 K ECFL,ECFR,ECGRP,ECH,ECHD,ECHEAD,ECI,ECID,ECIEN,ECIFN,ECIN 14 K ECINST,ECINV,ECIV,ECJ,ECK,ECL,ECL1,ECLAN,ECLAST,ECLDT,ECLINK,ECLIST 15 K ECLL,ECLN,ECLOC,ECLRN,ECLX,ECLY,ECM,ECMAX,ECMIN 16 K ECXMISS,ECMN,ECMOD,ECMODS,ECMORE,ECMS,ECMSG,ECMSN,ECMT,ECMW,ECMY,ECN 17 K ECNA,ECNDC,ECNDF,ECNFC,ECNL,ECNO,ECNODE,ECNOGO 18 K ECNT,ECO,ECO0,ECO1,ECO2,ECOB,ECODE,ECODE0,ECODE1,ECOLD,ECONE,ECOPAY 19 K ECOPAYT,ECORTY,ECOS,ECP,ECPACK,ECPCE,ECPCE1,ECPCE2,ECPCE3,ECPCE4 20 K ECPCE5,ECPCE6,ECPCE7,ECPIECE,ECPN,ECPRC,ECPRO,ECODE2 21 K ECPROF,ECPT,ECPTF,ECPTPR,ECPTTM,ECQ,ECQT,ECQTY,ECRD,ECRE,ECRED,ECREF 22 K ECRFL,ECRN,ECROU,ECRR,ECRS,ECRSD,ECRTN,ECRX,ECS,ECSA,ECSC 23 K ECSD,ECSD1,ECSDN,ECSN,ECSR,ECSS,ECST,ECSTOP,ECSU,ECT,ECT1,ECTD,ECTD1 24 K ECTEMP,ECTM,ECTNTL,ECTOTAL,ECTREAT,ECTRT,ECTS,ECTY,ECXLOGIC,ECXDATES,ECXEST,ECXECE 25 D ^ECXKILL1 26 ; 27 AUDIT ;kill audit report variables, close slave printer 28 K ECX,ECXARRAY,ECXACC,ECXALL,ECXAUD,ECXCODE,ECXD,ECXDEF,ECXDESC,ECXDIV 29 K ECXRCST,ECXRQST,ECXEND,ECXERR,ECXEXT,ECXHEAD,ECXLOC,ECXPGM,ECXPHCPC 30 K ECXPRIME,ECXPRO,ECXREPT,ECXRUN,ECXSAVE,ECXSTART,ECXSRCE 31 K ECXCTAMT,ECXFEKEY,ECXFELOC,ECXFORM,ECXGRPR,ECXHCPC,ECXPHCPC,ECXHCPCS 32 K ECXLAB,ECXLLC,ECXLMC,ECXQTY,ECXREQ,ECXSTAT,ECXTYPE 33 K IO("Q"),POP,DIR,DIC,DIE,DA,DR,DO,DIRUT,DUOUT,DTOUT 34 K ^TMP($J) 35 I IO=IO(0),IOST'="C" D ^%ZISC 36 Q -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXLABN.m
r613 r623 1 ECXLABN ;ALB/JAP,BIR/CML-Lab Extract for DSS (New Format - With LMIP Codes) ; 10/23/07 3:01pm 2 ;;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 3 BEG ;entry point 4 D SETUP I ECFILE="" Q 5 D ^ECXTRAC,^ECXKILL 6 Q 7 ; 8 START ; entry when queued 9 K ^LRO(64.03),^TMP($J,"ECXP") 10 N ECDOCPC 11 S LRSDT=ECSD,LREDT=ECED,QFLG=0 12 D ^LRCAPDSS 13 ;quit if no completion date for API compile 14 I '$P($G(^LRO(64.03,1,1,1,0)),U,4) Q 15 ;quit if tasked and user sends stop request 16 I $D(ZTQUEUED),$$S^%ZTLOAD D Q 17 .S QFLG=1 18 .K ^LRO(64.03) S ^LRO(64.03,0)="WKLD LOG FILE^64.03^" 19 ;otherwise, continue 20 K ECXDD D FIELD^DID(64.03,1,,"SPECIFIER","ECXDD") 21 S ECPROF=$E(+$P(ECXDD("SPECIFIER"),"P",2)),ECLRN=1 K ECXDD 22 F S ECLRN=$O(^LRO(64.03,ECLRN)) Q:'ECLRN D Q:QFLG 23 .Q:'$D(^LRO(64.03,ECLRN,0)) 24 .S EC1=^LRO(64.03,ECLRN,0),ECDOC=ECPROF_$P(EC1,U,2) 25 .S ECDOCNPI=$$NPI^XUSNPI("Individual_ID",$P(EC1,U,2),$P(EC1,U,4)) 26 .S:+ECDOCNPI'>0 ECDOCNPI="" S ECDOCNPI=$P(ECDOCNPI,U) 27 .S ECLOC=$P(EC1,U,15),EC=$P(EC1,U,3),ECDOCPC=$$PRVCLASS^ECXUTL($P(EC1,U,2),$P(EC1,U,4)) 28 .I EC]"" D GET 29 K ^LRO(64.03),^TMP($J,"ECXP") S ^LRO(64.03,0)="WKLD LOG FILE^64.03^" 30 K ECDOCNPI,ECXAGC,ECXL1,ECXL2 31 Q 32 ; 33 GET ;get data 34 N X,ECXSTN,QFLAG 35 S ECF=$S($P(EC,";",2)="DPT(":2,$P(EC,";",2)="LRT(67,":67,1:0) Q:'ECF 36 S ECIFN=$P(EC,";"),QFLAG=0 37 ;resolve ecloc 38 S ECXL1=+$P(ECLOC,";",1),ECXL2=$P(ECLOC,";",2) 39 I ECF=2 S ECLOC=$S(ECXL1>0:ECXL1,1:"") I ECXL2]"",ECXL2'="SC(" S ECLOC="" 40 I ECF=67 D S ECLOC=ECXSTN 41 .S (ECXSTN,ECXAGC)="" 42 .I (ECXL2'="DIC(4,")!('$D(^DIC(4,ECXL1))) S ECXSTN="XXXXX",ECXAGC="XX" Q 43 .S ECXSTN=$P(^DIC(4,ECXL1,"99"),U,1),ECXAGC=$E($P(^(99),U,5),1,2) 44 .S:ECXSTN="" ECXSTN="ZZZZZ" S:ECXAGC="" ECXAGC="ZZ" 45 S ECDT=$P(EC1,U,13),ECD=$P(ECDT,"."),ECTM=$$ECXTIME^ECXUTL(ECDT) 46 S ECWKLD=$P(EC1,U,11),ECWK="" I $D(^LAM(ECWKLD,0)) S ECWK=$P(^(0),U,2) 47 S (ECXADMDT,ECTREAT,ECNA,ECSN,ECMN,ECPTTM,ECPTPR,ECCLAS)="",ECA="O",ECXERR=0 48 S (ECPTNPI,ECASPR,ECCLAS2,ECASNPI)="" 49 ;get the patient data if record is in file #2 50 I ECF=2 D PAT(ECIFN,ECDT,.ECXERR) 51 Q:ECXERR 52 ;get patient data if record is in file #67 53 I ECF=67 S ECSN="000123456",ECNA="RFRL" I $D(^LRT(67,ECIFN,0)) D Q:QFLAG 54 .S ECXMPI="",EC0=^LRT(67,ECIFN,0),ECNA=$E($P($P(EC0,U),",")_" ",1,4) 55 .S ECSN=$P(EC0,U,9),ECXERI="" D 56 ..S ECNA=$TR(ECNA,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") 57 ..I ECSN="" S ECSN="000123456" Q 58 ..S ECSN=$TR(ECSN," "),ECSN=$TR(ECSN,"-") 59 ..I ($L(ECSN)<9)!($L(ECSN)>10) S ECSN="000123456" Q 60 ..I $L(ECSN)=9,ECSN'?9N S ECSN="000123456" Q 61 ..I $L(ECSN)=10,ECSN'?9N1"P" S ECSN="000123456" 62 ..I '$$SSN^ECXUTL5(ECSN,ECF) S QFLAG=1 63 ; 64 ;- Only set treating spec (TS) to TS in file #64.03 if it does not exist 65 I ECA="I",ECTREAT="" S ECTREAT=$P($G(^DIC(45.7,+$P(EC1,U,10),0)),U,2) 66 S (ECXDOM,ECXDSSD)="" 67 S X=$G(^ECX(727.831,+ECTREAT,0)) S:X'="" ECXDOM=$P(X,U,2) 68 ; 69 ;- Get ordering stop code and ordering date 70 S ECXORDST=+$P(EC1,U,15),ECXORDST=$S(ECXORDST:$P($G(^ECX(728.44,ECXORDST,0)),U,2),1:"") 71 S ECXORDDT=$S($P(EC1,U,14):$$ECXDATE^ECXUTL($P(EC1,U,14),ECXYM),1:"") 72 ; 73 ;- Get Production Division - ECXDIEN added p-80 74 N ECXPDIV,ECXDIEN S ECXDIEN=$O(^DIC(4,"D",ECINST,"")),ECXPDIV=$$RADDIV^ECXDEPT(ECXDIEN) ;P-46 75 K ECXDIEN 76 ; 77 ;- Observation patient indicator (YES/NO) 78 S ECXOBS=$$OBSPAT^ECXUTL4(ECA,ECTREAT) 79 ; 80 ;- If no encounter number don't file record 81 S ECXENC=$$ENCNUM^ECXUTL4(ECA,ECSN,ECXADMDT,ECD,ECTREAT,ECXOBS,ECHEAD,,) Q:ECXENC="" 82 ;create extract record only if patient name and accession area exist 83 I ECNA]"" S ECT=$P(EC1,U,8),ECURG=$P(EC1,U,9),EC=+$P(EC1,U,7) I EC D 84 .S:ECF=2 ECACA=EC_U_$P($G(^LRO(68,EC,0)),U,11) 85 .S:ECF=67 ECACA=ECXAGC_U_$P($G(^LRO(68,EC,0)),U,11) 86 .D FILE 87 Q 88 ; 89 PAT(ECXDFN,ECXDATE,ECXERR) ;get/set patient data 90 N X,OK,PT 91 ;get data 92 I $D(^TMP($J,"ECXP",ECXDFN)) D 93 .S PT=^TMP($J,"ECXP",ECXDFN),ECNA=$P(PT,U) 94 .S ECSN=$P(PT,U,2),ECXMPI=$P(PT,U,3),ECXERI=$P(PT,U,4) 95 ;set data and save for later 96 I '$D(^TMP($J,"ECXP",ECXDFN)) D Q:'OK 97 .K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECSD,"."),"1;3",.ECXPAT) 98 .I 'OK S ECXERR=1 Q 99 .S ECNA=ECXPAT("NAME"),ECSN=ECXPAT("SSN"),ECXMPI=ECXPAT("MPI") 100 .S ECXERI=ECXPAT("ERI") 101 .S ^TMP($J,"ECXP",ECXDFN)=ECNA_U_ECSN_U_ECXMPI_U_ECXERI 102 ;get date specific data 103 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) 104 S X=$$PRIMARY^ECXUTL2(ECXDFN,$P(ECXDATE,"."),ECPROF) 105 S ECPTTM=$P(X,U,1),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4) 106 S ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7) 107 Q 108 ; 109 FILE ;file record 110 ;node0 111 ;facility^patient number^SSN (or equivalent)^name^in/out ECA^ 112 ;day^accession area^abbreviation^test^urgency^treating spec^ 113 ;location^provider and file^ 114 ;movement number^file^time^workload code^primary care team^ 115 ;primary care provider 116 ;node1 117 ;mpi^dss dept^provider npi^pc provider npi^pc prov person class^ 118 ;assoc pc prov^assoc pc prov person class^assoc pc prov npi^ 119 ;dom ECXDOM^observ pat ind ECXOBS^encounter num ECXENC^ 120 ;ord stop code ECXORDST^ord date ECXORDDT^production division 121 ;ECXPDIV^^ordering provider person class^emergency response indicator 122 ;(FEMA) ECXERI^associate pc provider npi ECASNPI^primary care provider 123 ;npi ECPTNPI^provider npi ECDOCNPI 124 ;ECDOCPC 125 N DA,DIK 126 S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 127 S ECODE=EC7_U_EC23_U_ECINST_U_ECIFN_U_ECSN_U_ECNA_U_ECA_U 128 S ECODE=ECODE_$$ECXDATE^ECXUTL(ECD,ECXYM)_U_ECACA_U_ECT_U_ECURG_U 129 ;convert specialty to PTF Code for transmission 130 N ECXDATA 131 S ECXDATA=$$TSDATA^DGACT(42.4,+ECTREAT,.ECXDATA) 132 S ECTREAT=$G(ECXDATA(7)) 133 ;done 134 S ECODE=ECODE_ECTREAT_U_ECLOC_U_ECDOC_U_ECMN_U_ECF_U_ECTM_U_ECWK_U 135 S ECODE=ECODE_ECPTTM_U_ECPTPR_U 136 ;(ECACA=acc area^abbreviation) 137 S ECODE1=ECXMPI_U_ECXDSSD_U_U_U_ECCLAS_U_ECASPR_U 138 S ECODE1=ECODE1_ECCLAS2_U_U_ECXDOM_U_ECXOBS_U_ECXENC_U 139 S ECODE1=ECODE1_ECXORDST_U_ECXORDDT_U_ECXPDIV_U 140 I ECXLOGIC>2004 S ECODE1=ECODE1_U_ECDOCPC 141 I ECXLOGIC>2006 S ECODE1=ECODE1_U_ECXERI 142 I ECXLOGIC>2007 S ECODE1=ECODE1_U_ECASNPI_U_ECPTNPI_U_ECDOCNPI 143 S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,ECRN=ECRN+1 144 S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA 145 I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 146 Q 147 ; 148 SETUP ;Set required input for ECXTRAC 149 S ECHEAD="LAB" 150 D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) 151 Q 152 ; 153 QUE ; entry point for the background requeuing handled by ECXTAUTO 154 D SETUP,QUE^ECXTAUTO,^ECXKILL Q 1 ECXLABN ;ALB/JAP,BIR/CML-Lab Extract for DSS (New Format - With LMIP Codes) ; 4/25/07 8:52am 2 ;;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 3 BEG ;entry point 4 D SETUP I ECFILE="" Q 5 D ^ECXTRAC,^ECXKILL 6 Q 7 ; 8 START ; entry when queued 9 K ^LRO(64.03),^TMP($J,"ECXP") 10 N ECDOCPC 11 S LRSDT=ECSD,LREDT=ECED,QFLG=0 12 D ^LRCAPDSS 13 ;quit if no completion date for API compile 14 I '$P($G(^LRO(64.03,1,1,1,0)),U,4) Q 15 ;quit if tasked and user sends stop request 16 I $D(ZTQUEUED),$$S^%ZTLOAD D Q 17 .S QFLG=1 18 .K ^LRO(64.03) S ^LRO(64.03,0)="WKLD LOG FILE^64.03^" 19 ;otherwise, continue 20 K ECXDD D FIELD^DID(64.03,1,,"SPECIFIER","ECXDD") 21 S ECPROF=$E(+$P(ECXDD("SPECIFIER"),"P",2)),ECLRN=1 K ECXDD 22 F S ECLRN=$O(^LRO(64.03,ECLRN)) Q:'ECLRN D Q:QFLG 23 .Q:'$D(^LRO(64.03,ECLRN,0)) 24 .S EC1=^LRO(64.03,ECLRN,0),ECDOC=ECPROF_$P(EC1,U,2),ECDOCNPI="" 25 .S ECLOC=$P(EC1,U,15),EC=$P(EC1,U,3),ECDOCPC=$$PRVCLASS^ECXUTL($P(EC1,U,2),$P(EC1,U,4)) 26 .I EC]"" D GET 27 K ^LRO(64.03),^TMP($J,"ECXP") S ^LRO(64.03,0)="WKLD LOG FILE^64.03^" 28 K ECDOCNPI,ECXAGC,ECXL1,ECXL2 29 Q 30 ; 31 GET ;get data 32 N X,ECXSTN 33 S ECF=$S($P(EC,";",2)="DPT(":2,$P(EC,";",2)="LRT(67,":67,1:0) Q:'ECF 34 S ECIFN=$P(EC,";") 35 ;resolve ecloc 36 S ECXL1=+$P(ECLOC,";",1),ECXL2=$P(ECLOC,";",2) 37 I ECF=2 S ECLOC=$S(ECXL1>0:ECXL1,1:"") I ECXL2]"",ECXL2'="SC(" S ECLOC="" 38 I ECF=67 D S ECLOC=ECXSTN 39 .S (ECXSTN,ECXAGC)="" 40 .I (ECXL2'="DIC(4,")!('$D(^DIC(4,ECXL1))) S ECXSTN="XXXXX",ECXAGC="XX" Q 41 .S ECXSTN=$P(^DIC(4,ECXL1,"99"),U,1),ECXAGC=$E($P(^(99),U,5),1,2) 42 .S:ECXSTN="" ECXSTN="ZZZZZ" S:ECXAGC="" ECXAGC="ZZ" 43 S ECDT=$P(EC1,U,13),ECD=$P(ECDT,"."),ECTM=$$ECXTIME^ECXUTL(ECDT) 44 S ECWKLD=$P(EC1,U,11),ECWK="" I $D(^LAM(ECWKLD,0)) S ECWK=$P(^(0),U,2) 45 S (ECXADMDT,ECTREAT,ECNA,ECSN,ECMN,ECPTTM,ECPTPR,ECCLAS)="",ECA="O",ECXERR=0 46 S (ECPTNPI,ECASPR,ECCLAS2,ECASNPI)="" 47 ;get the patient data if record is in file #2 48 I ECF=2 D PAT(ECIFN,ECDT,.ECXERR) 49 Q:ECXERR 50 ;get patient data if record is in file #67 51 I ECF=67 S ECSN="000123456",ECNA="RFRL" I $D(^LRT(67,ECIFN,0)) D 52 .S ECXMPI="",EC0=^LRT(67,ECIFN,0),ECNA=$E($P($P(EC0,U),",")_" ",1,4) 53 .S ECSN=$P(EC0,U,9),ECXERI="" D 54 ..S ECNA=$TR(ECNA,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") 55 ..I ECSN="" S ECSN="000123456" Q 56 ..S ECSN=$TR(ECSN," "),ECSN=$TR(ECSN,"-") 57 ..I ($L(ECSN)<9)!($L(ECSN)>10) S ECSN="000123456" Q 58 ..I $L(ECSN)=9,ECSN'?9N S ECSN="000123456" Q 59 ..I $L(ECSN)=10,ECSN'?9N1"P" S ECSN="000123456" 60 ; 61 ;- Only set treating spec (TS) to TS in file #64.03 if it does not exist 62 I ECA="I",ECTREAT="" S ECTREAT=$P($G(^DIC(45.7,+$P(EC1,U,10),0)),U,2) 63 S (ECXDOM,ECXDSSD)="" 64 S X=$G(^ECX(727.831,+ECTREAT,0)) S:X'="" ECXDOM=$P(X,U,2) 65 ; 66 ;- Get ordering stop code and ordering date 67 S ECXORDST=+$P(EC1,U,15),ECXORDST=$S(ECXORDST:$P($G(^ECX(728.44,ECXORDST,0)),U,2),1:"") 68 S ECXORDDT=$S($P(EC1,U,14):$$ECXDATE^ECXUTL($P(EC1,U,14),ECXYM),1:"") 69 ; 70 ;- Get Production Division - ECXDIEN added p-80 71 N ECXPDIV,ECXDIEN S ECXDIEN=$O(^DIC(4,"D",ECINST,"")),ECXPDIV=$$RADDIV^ECXDEPT(ECXDIEN) ;P-46 72 K ECXDIEN 73 ; 74 ;- Observation patient indicator (YES/NO) 75 S ECXOBS=$$OBSPAT^ECXUTL4(ECA,ECTREAT) 76 ; 77 ;- If no encounter number don't file record 78 S ECXENC=$$ENCNUM^ECXUTL4(ECA,ECSN,ECXADMDT,ECD,ECTREAT,ECXOBS,ECHEAD,,) Q:ECXENC="" 79 ;create extract record only if patient name and accession area exist 80 I ECNA]"" S ECT=$P(EC1,U,8),ECURG=$P(EC1,U,9),EC=+$P(EC1,U,7) I EC D 81 .S:ECF=2 ECACA=EC_U_$P($G(^LRO(68,EC,0)),U,11) 82 .S:ECF=67 ECACA=ECXAGC_U_$P($G(^LRO(68,EC,0)),U,11) 83 .D FILE 84 Q 85 ; 86 PAT(ECXDFN,ECXDATE,ECXERR) ;get/set patient data 87 N X,OK,PT 88 ;get data 89 I $D(^TMP($J,"ECXP",ECXDFN)) D 90 .S PT=^TMP($J,"ECXP",ECXDFN),ECNA=$P(PT,U) 91 .S ECSN=$P(PT,U,2),ECXMPI=$P(PT,U,3),ECXERI=$P(PT,U,4) 92 ;set data and save for later 93 I '$D(^TMP($J,"ECXP",ECXDFN)) D Q:'OK 94 .K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECSD,"."),"1;3",.ECXPAT) 95 .I 'OK S ECXERR=1 Q 96 .S ECNA=ECXPAT("NAME"),ECSN=ECXPAT("SSN"),ECXMPI=ECXPAT("MPI") 97 .S ECXERI=ECXPAT("ERI") 98 .S ^TMP($J,"ECXP",ECXDFN)=ECNA_U_ECSN_U_ECXMPI_U_ECXERI 99 ;get date specific data 100 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) 101 S X=$$PRIMARY^ECXUTL2(ECXDFN,$P(ECXDATE,"."),ECPROF) 102 S ECPTTM=$P(X,U,1),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4) 103 S ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7) 104 Q 105 ; 106 FILE ;file record 107 ;node0 108 ;facility^patient number^SSN (or equivalent)^name^in/out ECA^ 109 ;day^accession area^abbreviation^test^urgency^treating spec^ 110 ;location^provider and file^ 111 ;movement number^file^time^workload code^primary care team^ 112 ;primary care provider 113 ;node1 114 ;mpi^dss dept^provider npi^pc provider npi^pc prov person class^ 115 ;assoc pc prov^assoc pc prov person class^assoc pc prov npi^ 116 ;dom ECXDOM^observ pat ind ECXOBS^encounter num ECXENC^ 117 ;ord stop code ECXORDST^ord date ECXORDDT^production division 118 ;ECXPDIV^^ordering provider person class^emergency response indicator 119 ;(FEMA) ECXERI 120 ;ECDOCPC 121 N DA,DIK 122 S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 123 S ECODE=EC7_U_EC23_U_ECINST_U_ECIFN_U_ECSN_U_ECNA_U_ECA_U 124 S ECODE=ECODE_$$ECXDATE^ECXUTL(ECD,ECXYM)_U_ECACA_U_ECT_U_ECURG_U 125 ;convert specialty to PTF Code for transmission 126 N ECXDATA 127 S ECXDATA=$$TSDATA^DGACT(42.4,+ECTREAT,.ECXDATA) 128 S ECTREAT=$G(ECXDATA(7)) 129 ;done 130 S ECODE=ECODE_ECTREAT_U_ECLOC_U_ECDOC_U_ECMN_U_ECF_U_ECTM_U_ECWK_U 131 S ECODE=ECODE_ECPTTM_U_ECPTPR_U 132 ;(ECACA=acc area^abbreviation) 133 S ECODE1=ECXMPI_U_ECXDSSD_U_ECDOCNPI_U_ECPTNPI_U_ECCLAS_U_ECASPR_U 134 S ECODE1=ECODE1_ECCLAS2_U_ECASNPI_U_ECXDOM_U_ECXOBS_U_ECXENC_U 135 S ECODE1=ECODE1_ECXORDST_U_ECXORDDT_U_ECXPDIV_U 136 I ECXLOGIC>2004 S ECODE1=ECODE1_U_ECDOCPC 137 I ECXLOGIC>2006 S ECODE1=ECODE1_U_ECXERI 138 S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,ECRN=ECRN+1 139 S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA 140 I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 141 Q 142 ; 143 SETUP ;Set required input for ECXTRAC 144 S ECHEAD="LAB" 145 D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) 146 Q 147 ; 148 QUE ; entry point for the background requeuing handled by ECXTAUTO 149 D SETUP,QUE^ECXTAUTO,^ECXKILL Q -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXLABR.m
r613 r623 1 ECXLABR ;ALB/JAP,BIR/CML-LAR Extract for DSS (New Format - With LMIP Codes) ; 6/5/07 2:33pm 2 ;;3.0;DSS EXTRACTS;**8,24,33,37,39,46,71,80,107,105**;Dec 22, 1997;Build 70 3 BEG ;entry point from option 4 D SETUP I ECFILE="" Q 5 D ^ECXTRAC,^ECXKILL 6 Q 7 ; 8 START ; entry when queued 9 N X,OK,ECTRS,ECTRANS,ECTRIEN,ECDOC,ECDOCPC 10 K ^LAR(64.036) S LRSDT=ECSD,LREDT=ECED 11 D ^LRCAPDAR 12 ;quit if no completion date for API compile 13 I '$P($G(^LAR(64.036,1,2,1,0)),U,4) Q 14 ;build local array of workload codes for local lab tests linked to 15 ;DSS tests 16 K ECLOC S ECDTST=0 17 F S ECDTST=$O(^ECX(727.2,1,1,ECDTST)) Q:('ECDTST) S ECLTST=0 D 18 .F S ECLTST=$O(^ECX(727.2,1,1,ECDTST,"LOC",ECLTST)) Q:'ECLTST D 19 ..S ECLTIEN=+^ECX(727.2,1,1,ECDTST,"LOC",ECLTST,0) 20 ..S ECWCDA=+$G(^LAB(60,ECLTIEN,64)) 21 ..I ECWCDA S ECWC=$P(^LAM(ECWCDA,0),U,2),ECLOC(ECWCDA)=ECWC 22 K ECLTIEN 23 ;process temporary lab file #64.036 24 S QFLG=0,ECLRN=1 25 F S ECLRN=$O(^LAR(64.036,ECLRN)) Q:('ECLRN)!(QFLG) D 26 .I $D(^LAR(64.036,ECLRN,0)) D 27 ..S EC1=^LAR(64.036,ECLRN,0),ECF=$P(EC1,U,2) 28 ..Q:ECF="" 29 ..S ECXDFN=$P(EC1,U,3),ECPTPR=$P($G(EC1),U,11),ECCLASS="" 30 ..S ECXTIME=$S($P(EC1,U,10)="":"000300",1:$P(EC1,U,10)) 31 ..S ECXDATE=$P(EC1,U,9)_"."_$P(EC1,U,10) 32 ..I ECPTPR S ECCLASS=$$PRVCLASS^ECXUTL(ECPTPR,ECXDATE) 33 ..I ECPTPR S ECPTNPI=$$NPI^XUSNPI("Individual_ID",ECPTPR,+ECXDATE) D 34 ...S:+ECPTNPI'>0 ECPTNPI="" S ECPTNPI=$P(ECPTNPI,U) 35 ..S ECORDT=$$ECXDATE^ECXUTL($P(EC1,U,4),ECXYM) 36 ..S ECORTM=$$ECXTIME^ECXUTL($P(EC1,U,4)_"."_$P(EC1,U,5)) 37 ..S ECREDT=$$ECXDATE^ECXUTL($P(EC1,U,6),ECXYM) 38 ..S ECRETM=$$ECXTIME^ECXUTL($P(EC1,U,6)_"."_$P(EC1,U,7)) 39 ..S ECSCDT=$$ECXDATE^ECXUTL($P(EC1,U,9),ECXYM) 40 ..S ECSCTM=$$ECXTIME^ECXUTL($P(EC1,U,9)_"."_$P(EC1,U,10)) 41 ..S (ECXADMDT,ECXDOM,ECXDSSD,ECXPNM,ECXSSN,ECXA,ECXMN,ECXTS)="" 42 ..I ECF=2 D Q:'OK 43 ...K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,ECXDATE,"1;",.ECXPAT) 44 ...Q:'OK 45 ...S ECXPNM=ECXPAT("NAME"),ECXSSN=ECXPAT("SSN"),ECXMPI=ECXPAT("MPI") 46 ...S X=$$INP^ECXUTL2(ECXDFN,ECXDATE),ECXA=$P(X,U),ECXADMDT=$P(X,U,4) 47 ...S ECXMN=$P(X,U,2),ECXTS=$P(X,U,3),ECXDOM=$P(X,U,10) 48 ..;allow for referral patients in future?? 49 ..;I ECF=67 S ECSN="000123456",ECNA="RFRL" 50 ..;loop on results multiple 51 ..; 52 ..;Get production division ECXDIEN added p-80 53 ..N ECXPDIV,ECXDIEN S ECXDIEN=$O(^DIC(4,"D",ECINST,"")),ECXPDIV=$$RADDIV^ECXDEPT(ECXDIEN) ;p-46 54 ..K ECXDIEN 55 ..;- Observation patient indicator (y/n) 56 ..S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS) 57 ..; 58 ..;- If no encounter number don't file record 59 ..S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,$P(EC1,U,9),ECXTS,ECXOBS,ECHEAD,,) Q:ECXENC="" 60 ..S ECRES=0 61 ..F S ECRES=$O(^LAR(64.036,ECLRN,1,ECRES)) Q:('ECRES)!(QFLG) D 62 ...I $D(^LAR(64.036,ECLRN,1,ECRES,0)) D Q:QFLG 63 ....S EC2=^LAR(64.036,ECLRN,1,ECRES,0),ECN=$P(EC2,U),ECRS=$P(EC2,U,2) 64 ....S ECHL=$E($P(EC2,U,3)),ECWC=+$P(EC2,U,4) 65 ....S ECWC=$S($D(ECLOC(ECWC)):ECLOC(ECWC),1:"") 66 ....; 67 ....; - Free text results translation 68 ....S ECTRANS="",ECTRS=ECRS 69 ....I +ECTRS S ECTRS=$TR(ECTRS,",","") D 70 .....I (ECTRS?.N)!(ECTRS?.N1".".N) S ECRS=ECTRS 71 ....F Q:$E(ECTRS,1)'=" " S ECTRS=$E(ECTRS,2,$L(ECTRS)) 72 ....F Q:$E(ECTRS,$L(ECTRS))'=" " S ECTRS=$E(ECTRS,1,($L(ECTRS)-1)) 73 ....I ECTRS]"" I ECTRS'?.N I ECTRS'?.N1".".N D ;translate 74 .....S ECTRS=$TR(ECRS,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") 75 .....S ECTRIEN="",ECTRIEN=$O(^ECX(727.7,"B",ECTRS,ECTRIEN)) 76 .....S ECTRANS=$S(ECTRIEN:$P(^ECX(727.7,ECTRIEN,0),U,2),1:5) 77 ....; 78 ....I ECWC]"" D FILE 79 K ^LAR(64.036) S ^LAR(64.036,0)="LAB DSS LAR EXTRACT^64.036^" 80 Q 81 ; 82 FILE ;file record 83 ;node0 84 ;facility (ECINST)^dfn (ECXDFN)^ssn (ECXSSN)^name(ECXPNM)^in/out (ECXA)^ 85 ;day(ECSCDT)^ 86 ;lab test code (ECN)^results (ECRS)^hi/lo indicator (ECHL)^ 87 ;date ordered (ECORDT)^time ordered (ECORTM)^date ready (ECREDT)^ 88 ;time ready (ECRETM)^ 89 ;movement file # (ECXMN)^treating specialty (ECXTS)^ 90 ;workload code(ECWC)^ 91 ;node1 92 ;mpi (ECXMPI)^dss dept (ECXDSSD)^dom (ECXDOM)^time (ECSCTM)^ 93 ;observ pat ind (ECXOBS)^encounter num (ECXENC)^prod div ECXPDIV^ 94 ;lab results translation ECXTRANS^ordering provider (ECPTPR)^ 95 ;ordering provider person class (ECCLASS)^ordering provider npi ECPTNPI 96 N DA,DIK 97 S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 98 S ECODE=EC7_U_EC23_U_ECINST_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U 99 S ECODE=ECODE_ECSCDT_U_$$RJ^XLFSTR(ECN,4,0)_U_ECRS_U_ECHL_U_ECORDT_U 100 S ECODE=ECODE_$$LJ^XLFSTR(ECORTM,6,0)_U 101 ;convert specialty to PTF Code for transmission 102 N ECXDATA 103 S ECXDATA=$$TSDATA^DGACT(42.4,+ECXTS,.ECXDATA) 104 S ECXTS=$G(ECXDATA(7)) 105 ;done 106 S ECODE=ECODE_ECREDT_U_$$LJ^XLFSTR(ECRETM,6,0)_U_ECXMN_U_ECXTS_U_ECWC_U 107 S ECODE1=ECXMPI_U_ECXDSSD_U_ECXDOM_U_ECSCTM_U_ECXOBS_U_ECXENC_U_ECXPDIV_U_ECTRANS 108 I ECXLOGIC>2004 S ECODE1=ECODE1_U_2_ECPTPR_U_ECCLASS 109 I ECXLOGIC>2007 S ECODE1=ECODE1_U_ECPTNPI 110 S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,ECRN=ECRN+1 111 S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA 112 I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 113 Q 114 ; 115 SETUP ;Set required input for ECXTRAC 116 S ECHEAD="LAR" 117 D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) 118 Q 119 ; 120 QUE ; entry point for the background requeuing handled by ECXTAUTO 121 D SETUP,QUE^ECXTAUTO,^ECXKILL Q 1 ECXLABR ;ALB/JAP,BIR/CML-LAR Extract for DSS (New Format - With LMIP Codes) ; 4/12/07 8:43am 2 ;;3.0;DSS EXTRACTS;**8,24,33,37,39,46,71,80,107**;Dec 22, 1997;Build 9 3 BEG ;entry point from option 4 D SETUP I ECFILE="" Q 5 D ^ECXTRAC,^ECXKILL 6 Q 7 ; 8 START ; entry when queued 9 N X,OK,ECTRS,ECTRANS,ECTRIEN,ECDOC,ECDOCPC 10 K ^LAR(64.036) S LRSDT=ECSD,LREDT=ECED 11 D ^LRCAPDAR 12 ;quit if no completion date for API compile 13 I '$P($G(^LAR(64.036,1,2,1,0)),U,4) Q 14 ;build local array of workload codes for local lab tests linked to 15 ;DSS tests 16 K ECLOC S ECDTST=0 17 F S ECDTST=$O(^ECX(727.2,1,1,ECDTST)) Q:('ECDTST) S ECLTST=0 D 18 .F S ECLTST=$O(^ECX(727.2,1,1,ECDTST,"LOC",ECLTST)) Q:'ECLTST D 19 ..S ECLTIEN=+^ECX(727.2,1,1,ECDTST,"LOC",ECLTST,0) 20 ..S ECWCDA=+$G(^LAB(60,ECLTIEN,64)) 21 ..I ECWCDA S ECWC=$P(^LAM(ECWCDA,0),U,2),ECLOC(ECWCDA)=ECWC 22 K ECLTIEN 23 ;process temporary lab file #64.036 24 S QFLG=0,ECLRN=1 25 F S ECLRN=$O(^LAR(64.036,ECLRN)) Q:('ECLRN)!(QFLG) D 26 .I $D(^LAR(64.036,ECLRN,0)) D 27 ..S EC1=^LAR(64.036,ECLRN,0),ECF=$P(EC1,U,2) 28 ..Q:ECF="" 29 ..S ECXDFN=$P(EC1,U,3),ECPTPR=$P($G(EC1),U,11),ECCLASS="" 30 ..S ECXTIME=$S($P(EC1,U,10)="":"000300",1:$P(EC1,U,10)) 31 ..S ECXDATE=$P(EC1,U,9)_"."_$P(EC1,U,10) 32 ..I ECPTPR S ECCLASS=$$PRVCLASS^ECXUTL(ECPTPR,ECXDATE) 33 ..S ECORDT=$$ECXDATE^ECXUTL($P(EC1,U,4),ECXYM) 34 ..S ECORTM=$$ECXTIME^ECXUTL($P(EC1,U,4)_"."_$P(EC1,U,5)) 35 ..S ECREDT=$$ECXDATE^ECXUTL($P(EC1,U,6),ECXYM) 36 ..S ECRETM=$$ECXTIME^ECXUTL($P(EC1,U,6)_"."_$P(EC1,U,7)) 37 ..S ECSCDT=$$ECXDATE^ECXUTL($P(EC1,U,9),ECXYM) 38 ..S ECSCTM=$$ECXTIME^ECXUTL($P(EC1,U,9)_"."_$P(EC1,U,10)) 39 ..S (ECXADMDT,ECXDOM,ECXDSSD,ECXPNM,ECXSSN,ECXA,ECXMN,ECXTS)="" 40 ..I ECF=2 D Q:'OK 41 ...K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,ECXDATE,"1;",.ECXPAT) 42 ...Q:'OK 43 ...S ECXPNM=ECXPAT("NAME"),ECXSSN=ECXPAT("SSN"),ECXMPI=ECXPAT("MPI") 44 ...S X=$$INP^ECXUTL2(ECXDFN,ECXDATE),ECXA=$P(X,U),ECXADMDT=$P(X,U,4) 45 ...S ECXMN=$P(X,U,2),ECXTS=$P(X,U,3),ECXDOM=$P(X,U,10) 46 ..;allow for referral patients in future?? 47 ..;I ECF=67 S ECSN="000123456",ECNA="RFRL" 48 ..;loop on results multiple 49 ..; 50 ..;Get production division ECXDIEN added p-80 51 ..N ECXPDIV,ECXDIEN S ECXDIEN=$O(^DIC(4,"D",ECINST,"")),ECXPDIV=$$RADDIV^ECXDEPT(ECXDIEN) ;p-46 52 ..K ECXDIEN 53 ..;- Observation patient indicator (y/n) 54 ..S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS) 55 ..; 56 ..;- If no encounter number don't file record 57 ..S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,$P(EC1,U,9),ECXTS,ECXOBS,ECHEAD,,) Q:ECXENC="" 58 ..S ECRES=0 59 ..F S ECRES=$O(^LAR(64.036,ECLRN,1,ECRES)) Q:('ECRES)!(QFLG) D 60 ...I $D(^LAR(64.036,ECLRN,1,ECRES,0)) D Q:QFLG 61 ....S EC2=^LAR(64.036,ECLRN,1,ECRES,0),ECN=$P(EC2,U),ECRS=$P(EC2,U,2) 62 ....S ECHL=$E($P(EC2,U,3)),ECWC=+$P(EC2,U,4) 63 ....S ECWC=$S($D(ECLOC(ECWC)):ECLOC(ECWC),1:"") 64 ....; 65 ....; - Free text results translation 66 ....S ECTRANS="",ECTRS=ECRS 67 ....I +ECTRS S ECTRS=$TR(ECTRS,",","") D 68 .....I (ECTRS?.N)!(ECTRS?.N1".".N) S ECRS=ECTRS 69 ....F Q:$E(ECTRS,1)'=" " S ECTRS=$E(ECTRS,2,$L(ECTRS)) 70 ....F Q:$E(ECTRS,$L(ECTRS))'=" " S ECTRS=$E(ECTRS,1,($L(ECTRS)-1)) 71 ....I ECTRS]"" I ECTRS'?.N I ECTRS'?.N1".".N D ;translate 72 .....S ECTRS=$TR(ECRS,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") 73 .....S ECTRIEN="",ECTRIEN=$O(^ECX(727.7,"B",ECTRS,ECTRIEN)) 74 .....S ECTRANS=$S(ECTRIEN:$P(^ECX(727.7,ECTRIEN,0),U,2),1:5) 75 ....; 76 ....I ECWC]"" D FILE 77 K ^LAR(64.036) S ^LAR(64.036,0)="LAB DSS LAR EXTRACT^64.036^" 78 Q 79 ; 80 FILE ;file record 81 ;node0 82 ;facility (ECINST)^dfn (ECXDFN)^ssn (ECXSSN)^name(ECXPNM)^in/out (ECXA)^ 83 ;day(ECSCDT)^ 84 ;lab test code (ECN)^results (ECRS)^hi/lo indicator (ECHL)^ 85 ;date ordered (ECORDT)^time ordered (ECORTM)^date ready (ECREDT)^ 86 ;time ready (ECRETM)^ 87 ;movement file # (ECXMN)^treating specialty (ECXTS)^ 88 ;workload code(ECWC)^ 89 ;node1 90 ;mpi (ECXMPI)^dss dept (ECXDSSD)^dom (ECXDOM)^time (ECSCTM)^ 91 ;observ pat ind (ECXOBS)^encounter num (ECXENC)^prod div ECXPDIV^ 92 ;lab results translation ECXTRANS^ordering provider (ECPTPR)^ 93 ;ordering provider person class (ECCLASS) 94 N DA,DIK 95 S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 96 S ECODE=EC7_U_EC23_U_ECINST_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U 97 S ECODE=ECODE_ECSCDT_U_$$RJ^XLFSTR(ECN,4,0)_U_ECRS_U_ECHL_U_ECORDT_U 98 S ECODE=ECODE_$$LJ^XLFSTR(ECORTM,6,0)_U 99 ;convert specialty to PTF Code for transmission 100 N ECXDATA 101 S ECXDATA=$$TSDATA^DGACT(42.4,+ECXTS,.ECXDATA) 102 S ECXTS=$G(ECXDATA(7)) 103 ;done 104 S ECODE=ECODE_ECREDT_U_$$LJ^XLFSTR(ECRETM,6,0)_U_ECXMN_U_ECXTS_U_ECWC_U 105 S ECODE1=ECXMPI_U_ECXDSSD_U_ECXDOM_U_ECSCTM_U_ECXOBS_U_ECXENC_U_ECXPDIV_U_ECTRANS 106 I ECXLOGIC>2004 S ECODE1=ECODE1_U_2_ECPTPR_U_ECCLASS 107 S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,ECRN=ECRN+1 108 S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA 109 I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 110 Q 111 ; 112 SETUP ;Set required input for ECXTRAC 113 S ECHEAD="LAR" 114 D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) 115 Q 116 ; 117 QUE ; entry point for the background requeuing handled by ECXTAUTO 118 D SETUP,QUE^ECXTAUTO,^ECXKILL Q -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXLBB.m
r613 r623 1 ECXLBB ;DALOI/KML - DSS BLOOD BANK EXTRACT ; 8/12/08 1:00pm 2 ;;3.0;DSS EXTRACTS;**78,84,90,92,104,105,102**;Dec 22, 1997;Build 17 3 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021 4 ; access to the LAB DATA file (#63) is supported by 5 ; controlled subscription to IA 525 (global root ^LR) 6 ; access to the BLOOD PRODUCT (#66) is supported by IA 4510 7 BEG ;entry point from option 8 D SETUP I ECFILE="" Q 9 D ^ECXTRAC,^ECXKILL 10 Q 11 START ; Entry point from tasked job 12 ; begin package specific extract 13 N ECTRSP,ECADMT,ECTODT,ECENCTR,ECPAT,ECLRDFN,ECXPHY,ECXPHYPC,ECPHYNPI 14 N ECD,ECXDFN,ECARRY,EC66,ECERR,ECTRFDT,ECTRFTM,ECX,ECINOUT,ECXINST 15 ;variables ECFILE,EC23,ECXYM,ECINST,ECSD,ECSD1,ECED passed in 16 ; by taskmanager 17 ; ECED defined in ^ECXTRAC - it represents the end date of the extract 18 ; sort process. TRANSFUSION DATE should be within start and end dates 19 ; ECED and ECSD were assigned with input provided by the user interface 20 ; and ECSD1 = ECSD-.1 21 ; Read through the TRANSFUSION RECORD sub-file (63.017) of 22 ; the LAB DATA file (#63) 23 ;the global nodes containing transfusion record entries are constructed 24 ; by calculating the TRANSFUSION DATE/TIME (.01) 25 ; into its reverse date/time representation and then DINUM'd when 26 ;filing the record entry 27 ; ECD equals the reverse date/time of ECED+.3 and will need to be 28 ; reset for each DFN. 29 I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 Q ;quit if tasked and user sends stop request (QFLG assigned in ECXTRAC) 30 AUDRPT ; entry point for pre-extract audit report 31 S ECTODT=9999999-ECSD1,ECLRDFN=0 32 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 33 .; ECARRY(1)=TRANSFUSION DATE AND TIME, 34 .; ECARRY(3)=COMPONENT, ECARRY(4)=COMPONENT ABBREVIATION 35 .; ECARRY(5)=UNITS POOLED, ECARRY(6)=TRANSFUSION REACTION, 36 .; ECARRY(7)=VOLUME TRANSFUSED, ECARRY(8)=TRANSFUSION REACTION TYPE 37 .; ECARRY(9)=REQUESTING PROVIDER, ECARRY(10)=REQUEST. PROV. PERSON CLASS 38 .; ECARRY(11)=UNIT MODIFIED,ECARRY(12)=UNIT MODIFICATION 39 .; ECARRY(13)=PRODUCTION DIVISION CODE 40 . S ECARRY(1)=$P(EC0,"^"),EC66=$G(^LAB(66,$P(EC0,"^",2),0)) 41 . S ECARRY(3)=$E($P(EC66,"^"),1,15),ECARRY(4)=$P(EC66,"^",2) 42 . S ECARRY(5)=$S(+$P(EC0,"^",7)=0:1,1:+$P(EC0,"^",7)) 43 . S ECARRY(6)=$S($P(EC0,"^",8)=1:"Y",1:"N"),ECARRY(7)=$P(EC0,"^",10) 44 . S ECARRY(8)=$E($P($G(^LAB(65.4,+$P(EC0,"^",11),0)),"^"),1,10) 45 . S (ECARRY(9),ECARRY(10),ECARRY(13))="" D GETRPRV 46 . S ECARRY(11)=$$MODIFIED(),(ECXPHY,ECXPHYPC,ECPHYNPI)="" 47 . S ECARRY(12)=$S(ECARRY(11)="Y":$$UNITMODS(),1:"") 48 . D GETDATA 49 . K ECARRY 50 D AUDRPT^ECXLBB1 51 Q 52 UNITMODS() ; Get modification criteria from fields #.06 and #3 from file #66 53 N MODARY,MO,EC66A,MODSTR,STR3 54 S MODARY("DIVIDED")="D",MODARY("POOLED")="P",MODARY("WASHED")="W" 55 S MODARY("FROZEN")="F",MODARY("LEUKOCYTE POOR")="L" 56 S MODARY("REJUVENATED")="R",MODARY("DEGLYCEROLIZED")="G" 57 S MODARY("IRRADIATED")="I",MODARY("SEPARATED")="S" 58 ;if modification criteria is null determine value from description 59 S MODSTR=$S($P(EC66,U,6)'="":$P(EC66,U,6),1:$$CHKMOD^ECXLBB1($P(EC66,"^"))) 60 ;get modification criteria for entries at field #3 in file #66 61 S MOD=0 F S MOD=$O(^LAB(66,$P(EC0,"^",2),3,MOD)) Q:'MOD D 62 .S EC66A=$G(^LAB(66,MOD,0)) I EC66A="" Q 63 .S STR3=$S($P(EC66A,U,6)'="":$P(EC66A,U,6),1:$$CHKMOD^ECXLBB1($P(EC66A,"^"))) 64 .I STR3'="",MODSTR'[STR3 S MODSTR=MODSTR_STR3 65 Q MODSTR 66 MODIFIED() ; Was unit modified 67 ; Init variables 68 N XMATCH,UNIT,MOD,COMPID,MODNODE,MODTO 69 S (XMATCH,UNIT)=0,MOD="" 70 ; Check input 71 Q:'$G(ECLRDFN)!'$P(EC0,U,2) "N" 72 ;Find xmatch for blood component request 73 S XMATCH=$O(^LR(ECLRDFN,1.8,$P(EC0,U,2),1,XMATCH)) Q:'XMATCH "N" 74 ;Get blood inventory file (#65) pointer 75 S UNIT=$P($G(^LR(ECLRDFN,1.8,$P(EC0,"^",2),1,XMATCH,0)),U) 76 ;Look at disposition field (#4.1) in blood inventory file (#65) 77 S MOD=$P($G(^LRD(65,+XMATCH,4)),U),COMPID=$P(EC66,U,3) 78 ; Get 'the modified to' entry pointer to blood inventory file (#66) 79 I MOD="MO" S MODTO=0 F S MODTO=$O(^LRD(65,+XMATCH,9,MODTO)) Q:'MODTO D 80 .S MODNODE=$G(^LRD(65,+XMATCH,9,MODTO,0)) Q:$P(^(0),U,3)'>1 81 .Q:$P(MODNODE,U,2)'=COMPID 82 .; Set the modify to unit ien for file (#66) 83 Q $S(MOD="MO":"Y",1:"N") 84 GETRPRV ; get requesting provider, requesting provider person class and 85 ; production division code 86 ; input: ECD =INVERTED DATE SUBSCRIPT 87 ; ECARRY(1)=TRANSFUSION DATE AND TIME 88 ; note: Accessioned data in file #68 is stored up to 90 days. 89 N ECXBNOD,ACC,ACCDT,ACCNODE,PERCLS 90 I ECARRY(1)="" Q ;there is no transfusion date 91 ;get BLOOD BANK record, field #1, in file #63 located on "BB" node 92 ;since there is a slight time lapse, $O will find the BB record 93 S ECXBNOD=$O(^LR(ECLRDFN,"BB",ECD)) I ECXBNOD="" Q 94 S ECXBNOD=^LR(ECLRDFN,"BB",ECXBNOD,0) I ECXBNOD="" Q 95 ;Compose accession number,originating from field #.06 subfile #63.01 96 ; ex. ACC=BB 0528 27 97 S ACC=$P(ECXBNOD,U,6),ACC=$TR($P(ACC," ",2,99)," ") 98 S ACCDT=$E(ECARRY(1),1,3)_$E(ACC,1,4),NUM=$E(ACC,5,99) 99 ;Get field #2 from file #68, field #1 from subfile #68.01 which is 100 ;subfile #68.02. Look at 29=blood bank ien, from 0th node, get fields 101 ;#6.5 PROVIDER and #26 DIV 102 I (ACCDT)=""!(NUM="") Q 103 ; identify bb accession area the patient was in to get the right DIV 104 S AREA=$$AREA 105 S ACCNODE=$G(^LRO(68,+AREA,1,ACCDT,1,NUM,0)) 106 S ECARRY(9)=$P(ACCNODE,U,8) I ECARRY(9)'="" D 107 . S PERCLS=$$GET^XUA4A72(ECARRY(9),ACCDT) 108 . I +PERCLS>0 S ECARRY(10)=$P(PERCLS,U,7) 109 . S ECREQNPI=$$NPI^XUSNPI("Individual_ID",ECARRY(9),ACCDT) 110 . S:+ECREQNPI'>0 ECREQNPI="" S ECREQNPI=$P(ECREQNPI,U) 111 . S ECARRY(9)=2_ECARRY(9) 112 S DIV=$P($G(^LRO(68,+AREA,1,ACCDT,1,NUM,.4)),U) 113 I DIV'="" S ECARRY(13)=$$RADDIV^ECXDEPT(DIV) 114 Q 115 AREA() ; resolve accession area's ien to use and validate 116 ; Accession number 117 ; Patient LRDFN 118 ; note: if there is only one accession area use '29' 119 N A,CNT,BBLIST,DFN,ACC,AREA,DATE,TDATE,ACCNODE 120 S (CNT,FLAG,A)=0,DFN="" 121 ; set the date from the "bb" node in file (#63) 122 S DATE=$P(ECXBNOD,U) 123 ; setup array for bb accession areas if more than one 124 F S A=$O(^LRO(68,A)) Q:'A I $P($G(^LRO(68,A,0)),"^",2)="BB" D 125 . S BBLIST(A)="" 126 . S CNT=CNT+1 127 I CNT'>1 Q 29 128 S AREA=0 F S AREA=$O(BBLIST(AREA)) Q:'AREA D Q:FLAG 129 . ; get additional accession information for validation 130 . S ACCNODE=$G(^LRO(68,AREA,1,$P(DATE,"."),1,NUM,0)) 131 . S ACC=$G(^LRO(68,AREA,1,$P(DATE,"."),1,NUM,.2)) 132 . S DFN=$P($G(ACCNODE),U) 133 . S TDATE=$P($G(^LRO(68,AREA,1,$P(DATE,"."),1,NUM,3)),U) 134 . I (DFN=ECLRDFN)&(ACC=$P(ECXBNOD,U,6))&(DATE=TDATE) S FLAG=1 135 Q AREA 136 GETDATA ; gather rest of extract data that will be recorded in an 137 ; entry in file 727.829 138 S ECTRFDT=$$ECXDOB^ECXUTL(ECARRY(1)),ECTRFTM=$$ECXTIME^ECXUTL(ECARRY(1)) 139 S ECX=$$INP^ECXUTL2(ECXDFN,ECARRY(1)),ECINOUT=$P(ECX,U),ECTRSP=$P(ECX,U,3),ECADMT=$P(ECX,U,4) ; [FLD #5] 140 ; 141 ;- Observation patient indicator (YES/NO) 142 S ECXOBS=$$OBSPAT^ECXUTL4(ECINOUT,ECTRSP) 143 ;- If no encounter number don't file record 144 S ECENCTR=$$ENCNUM^ECXUTL4(ECINOUT,ECPAT("SSN"),ECADMT,ECARRY(1),ECTRSP,ECXOBS,ECHEAD,,) ; [FLD #6] 145 Q:ECENCTR="" 146 ;get emergency response indicator (FEMA) 147 S ECXERI=ECPAT("ERI") 148 ; 149 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)_"^^" 150 I $G(ECXLOGIC)>2005 S ECXSTR=ECXSTR_U_ECXPHY_U_ECXPHYPC 151 I $G(ECXLOGIC)>2006 D 152 .S ECXSTR=ECXSTR_U_ECXERI_U_ECARRY(11)_U_ECARRY(12)_U_ECARRY(9)_U_ECARRY(10)_U_ECARRY(13)_U 153 I '$D(ECXRPT) D FILE(ECXSTR) Q 154 S ^TMP("ECXLBB",$J,ECXDFN,ECD)=ECXSTR ;temporary global array 155 ; used in ECXPLBB (pre-extract audit report) 156 Q 157 GETDFN(ECXLRDFN) ; 158 ; INPUT - LRDFN 159 ; OUTPUT - DFN 160 ; Obtains DFN (Patient ID) from LRDFN (Lab Patient ID). 161 ; If no valid DFN exists, 0 is returned. 162 S ECXLRDFN=+$G(ECXLRDFN) 163 I $P($G(^LR(ECXLRDFN,0)),"^",2)'=2 Q 0 164 Q +$P(^LR(ECXLRDFN,0),"^",3) 165 ; 166 PAT(ECXDFN) ;get/set patient data 167 ; INPUT - ECXDFN = patient ien (DFN) 168 ; OUTPUT - ECPAT array: 169 ; ECPAT("SSN") 170 ; ECPAT("NAME") 171 ; returns 0 or 1 in ECXERR - 0=successful 172 ; 1=error condition 173 N X,OK,ECXERR 174 ;get data 175 S ECXERR=0 176 K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,"","1;3",.ECPAT) 177 I 'OK S ECXERR=1 178 Q ECXERR 179 ; 180 FILE(ECODE) ; 181 ; Input - ECODE = extract record 182 ; 183 ; record the extract record at a global node in file 727.829 184 ; sequence #^year/month of extract^extract #^facility^patient dfn^SSN^ 185 ; name^i/o pt indicator^encounter #^date of transfusion^time of 186 ; transfusion^component^component abbrev^# of units^volume in mm^ 187 ; reaction^reaction type^feeder location^DSS product dept^DSS IP # 188 ; ordering physician^ordering physician pc^emergency response indicator 189 ; (FEMA)^unit modified^unit modification^requesting provider^request. 190 ; provider person class^ordering provider npi ECPHYNPI 191 ;ECODE1- requesting provider npi ECREQNPI 192 ;note: DSS product dept and DSS IP # are dependent on the release of 193 ; ECX*3*61 194 N DA,DIK,EC7 195 S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 196 S ECODE=EC7_"^"_ECODE 197 I ECXLOGIC>2007 D 198 .S ECODE=ECODE_ECPHYNPI_U 199 .S ECODE1=$G(ECREQNPI) 200 S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=$G(ECODE1),ECRN=ECRN+1 201 S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA 202 Q 203 ; 204 ; 205 SETUP ;Set required input for ECXTRAC. 206 S ECHEAD="LBB" 207 D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) 208 Q 209 ; 210 LOCAL ; to extract nightly for local use not to be transmitted to TSI 211 ; should be queued with a 1D frequency 212 D SETUP,^ECXTLOCL,^ECXKILL Q 213 ; 214 QUE ; entry point for the background requeuing handled by ECXTAUTO 215 D SETUP,QUE^ECXTAUTO,^ECXKILL 216 Q 217 ; 218 ;ECXLBB 1 ECXLBB ;DALOI/KML - DSS BLOOD BANK EXTRACT ; 2/22/07 11:42am 2 ;;3.0;DSS EXTRACTS;**78,84,90,92,104**;Dec 22, 1997;Build 8 3 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021 4 ; access to the LAB DATA file (#63) is supported by 5 ; controlled subscription to IA 525 (global root ^LR) 6 ; access to the BLOOD PRODUCT (#66) is supported by IA 4510 7 BEG ;entry point from option 8 D SETUP I ECFILE="" Q 9 D ^ECXTRAC,^ECXKILL 10 Q 11 ; 12 START ; Entry point from tasked job 13 ; begin package specific extract 14 N ECTRSP,ECADMT,ECTODT,ECENCTR,ECPAT,ECLRDFN,ECXPHY,ECXPHYPC 15 N ECD,ECXDFN,ECARRY,EC66,ECERR,ECTRFDT,ECTRFTM,ECX,ECINOUT,ECXINST 16 ;variables ECFILE,EC23,ECXYM,ECINST,ECSD,ECSD1,ECED passed in 17 ; by taskmanager 18 ; ECED defined in ^ECXTRAC - it represents the end date of the extract 19 ; sort process. TRANSFUSION DATE should be within start and end dates 20 ; ECED and ECSD were assigned with input provided by the user interface 21 ; and ECSD1 = ECSD-.1 22 ; Read through the TRANSFUSION RECORD sub-file (63.017) of 23 ; the LAB DATA file (#63) 24 ;the global nodes containing transfusion record entries are constructed 25 ; by calculating the TRANSFUSION DATE/TIME (.01) 26 ; into its reverse date/time representation and then DINUM'd when 27 ;filing the record entry 28 ; ECD equals the reverse date/time of ECED+.3 and will need to be 29 ; reset for each DFN. 30 I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 Q ;quit if tasked and user sends stop request (QFLG assigned in ECXTRAC) 31 AUDRPT ; entry point for pre-extract audit report 32 S ECTODT=9999999-ECSD1,ECLRDFN=0 33 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 34 .; ECARRY(1)=TRANSFUSION DATE AND TIME, 35 .; ECARRY(3)=COMPONENT, ECARRY(4)=COMPONENT ABBREVIATION 36 .; ECARRY(5)=UNITS POOLED, ECARRY(6)=TRANSFUSION REACTION, 37 .; ECARRY(7)=VOLUME TRANSFUSED, ECARRY(8)=TRANSFUSION REACTION TYPE 38 .; ECARRY(9)=REQUESTING PROVIDER, ECARRY(10)=REQUEST. PROV. PERSON CLASS 39 .; ECARRY(11)=UNIT MODIFIED, ECARRY(12)=UNIT MODIFICATION 40 .; ECARRY(13)=PRODUCTION DIVISION CODE 41 . S ECARRY(1)=$P(EC0,"^"),EC66=$G(^LAB(66,$P(EC0,"^",2),0)) 42 . S ECARRY(3)=$E($P(EC66,"^"),1,15),ECARRY(4)=$P(EC66,"^",2) 43 . S ECARRY(5)=$S(+$P(EC0,"^",7)=0:1,1:+$P(EC0,"^",7)) 44 . S ECARRY(6)=$S($P(EC0,"^",8)=1:"Y",1:"N"),ECARRY(7)=$P(EC0,"^",10) 45 . S ECARRY(8)=$E($P($G(^LAB(65.4,+$P(EC0,"^",11),0)),"^"),1,10) 46 . S (ECARRY(9),ECARRY(10),ECARRY(13))="" D GETRPRV 47 . S ECARRY(12)=$$UNITMOD(),ECARRY(11)=$S(ECARRY(12)'="":"Y",1:"N") 48 . S (ECXPHY,ECXPHYPC)="" 49 . D GETDATA 50 . K ECARRY 51 Q 52 ; 53 UNITMOD() ; Get modification criteria from fields #.06 and #3 from file #66 54 N MODARY,MO,EC66A,MODSTR,STR3 55 S MODARY("DIVIDED")="D",MODARY("POOLED")="P",MODARY("WASHED")="W" 56 S MODARY("FROZEN")="F",MODARY("LEUKOCYTE POOR")="L" 57 S MODARY("REJUVENATED")="R",MODARY("DEGLYCEROLIZED")="G" 58 S MODARY("IRRADIATED")="I",MODARY("SEPARATED")="S" 59 ;if modification criteria is null determine value from description 60 S MODSTR=$S($P(EC66,U,6)'="":$P(EC66,U,6),1:$$CHKMOD($P(EC66,"^"))) 61 ;get modification criteria for entries at field #3 in file #66 62 S MOD=0 F S MOD=$O(^LAB(66,$P(EC0,"^",2),3,MOD)) Q:'MOD D 63 .S EC66A=$G(^LAB(66,MOD,0)) I EC66A="" Q 64 .S STR3=$S($P(EC66A,U,6)'="":$P(EC66A,U,6),1:$$CHKMOD($P(EC66A,"^"))) 65 .I STR3'="",MODSTR'[STR3 S MODSTR=MODSTR_STR3 66 Q MODSTR 67 ; 68 CHKMOD(MD) ;check if modifier is contained in string 69 N RES,MODX 70 I MD="" Q "" 71 S (RES,MODX)="" F S MODX=$O(MODARY(MODX)) Q:MODX="" D I RES'="" Q 72 .I MD[MODX S RES=MODARY(MODX) 73 Q RES 74 GETRPRV ; get requesting provider, requesting provider person class and 75 ; production division code 76 ; input: ECD =INVERTED DATE SUBSCRIPT 77 ; ECARRY(1)=TRANSFUSION DATE AND TIME 78 ; note: Accessioned data in file #68 is stored up to 90 days. 79 N ECXBNOD,ACC,ACCDT,ACCNODE,PERCLS 80 I ECARRY(1)="" Q ;there is no transfusion date 81 ;get BLOOD BANK record, field #1, in file #63 located on "BB" node 82 ;since there is a slight time lapse, $O will find the BB record 83 S ECXBNOD=$O(^LR(ECLRDFN,"BB",ECD)) I ECXBNOD="" Q 84 S ECXBNOD=^LR(ECLRDFN,"BB",ECXBNOD,0) I ECXBNOD="" Q 85 ;Compose accession number,originating from field #.06 subfile #63.01 86 ; ex. ACC=BB 0528 27 87 S ACC=$P(ECXBNOD,U,6),ACC=$TR($P(ACC," ",2,99)," ") 88 S ACCDT=$E(ECARRY(1),1,3)_$E(ACC,1,4),NUM=$E(ACC,5,99) 89 ;Get field #2 from file #68, field #1 from subfile #68.01 which is 90 ;subfile #68.02. Look at 29=blood bank ien, from 0th node, get fields 91 ;#6.5 PROVIDER and #26 DIV 92 I (ACCDT)=""!(NUM="") Q 93 ; identify bb accession area the patient was in to get the right DIV 94 S AREA=$$AREA 95 S ACCNODE=$G(^LRO(68,+AREA,1,ACCDT,1,NUM,0)) 96 S ECARRY(9)=$P(ACCNODE,U,8) I ECARRY(9)'="" D 97 . S PERCLS=$$GET^XUA4A72(ECARRY(9),ACCDT) 98 . I +PERCLS>0 S ECARRY(10)=$P(PERCLS,U,7) 99 . S ECARRY(9)=2_ECARRY(9) 100 S DIV=$P($G(^LRO(68,+AREA,1,ACCDT,1,NUM,.4)),U) 101 I DIV'="" S ECARRY(13)=$$RADDIV^ECXDEPT(DIV) 102 Q 103 ; 104 AREA() ; resolve accession area's ien to use and validate 105 ; Accession number 106 ; Patient LRDFN 107 ; note: if there is only one accession area use '29' 108 N A,CNT,BBLIST,DFN,ACC,AREA,DATE,TDATE,ACCNODE 109 S (CNT,FLAG,A)=0,DFN="" 110 ; set the date from the "bb" node in file (#63) 111 S DATE=$P(ECXBNOD,U) 112 ; setup array for bb accession areas if more than one 113 F S A=$O(^LRO(68,A)) Q:'A I $P($G(^LRO(68,A,0)),"^",2)="BB" D 114 . S BBLIST(A)="" 115 . S CNT=CNT+1 116 I CNT'>1 Q 29 117 S AREA=0 F S AREA=$O(BBLIST(AREA)) Q:'AREA D Q:FLAG 118 . ; get additional accession information for validation 119 . S ACCNODE=$G(^LRO(68,AREA,1,$P(DATE,"."),1,NUM,0)) 120 . S ACC=$G(^LRO(68,AREA,1,$P(DATE,"."),1,NUM,.2)) 121 . S DFN=$P($G(ACCNODE),U) 122 . S TDATE=$P($G(^LRO(68,AREA,1,$P(DATE,"."),1,NUM,3)),U) 123 . I (DFN=ECLRDFN)&(ACC=$P(ECXBNOD,U,6))&(DATE=TDATE) S FLAG=1 124 Q AREA 125 ; 126 GETDATA ; gather rest of extract data that will be recorded in an 127 ; entry in file 727.829 128 S ECTRFDT=$$ECXDOB^ECXUTL(ECARRY(1)),ECTRFTM=$$ECXTIME^ECXUTL(ECARRY(1)) 129 S ECX=$$INP^ECXUTL2(ECXDFN,ECARRY(1)),ECINOUT=$P(ECX,U),ECTRSP=$P(ECX,U,3),ECADMT=$P(ECX,U,4) ; [FLD #5] 130 ; 131 ;- Observation patient indicator (YES/NO) 132 S ECXOBS=$$OBSPAT^ECXUTL4(ECINOUT,ECTRSP) 133 ;- If no encounter number don't file record 134 S ECENCTR=$$ENCNUM^ECXUTL4(ECINOUT,ECPAT("SSN"),ECADMT,ECARRY(1),ECTRSP,ECXOBS,ECHEAD,,) ; [FLD #6] 135 Q:ECENCTR="" 136 ;get emergency response indicator (FEMA) 137 S ECXERI=ECPAT("ERI") 138 ; 139 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)_"^^" 140 I $G(ECXLOGIC)>2005 S ECXSTR=ECXSTR_U_ECXPHY_U_ECXPHYPC 141 I $G(ECXLOGIC)>2006 D 142 .S ECXSTR=ECXSTR_U_ECXERI_U_ECARRY(11)_U_ECARRY(12)_U_ECARRY(9)_U_ECARRY(10)_U_ECARRY(13) 143 I '$D(ECXRPT) D FILE(ECXSTR) Q 144 S ^TMP("ECXLBB",$J,ECXDFN,ECD)=ECXSTR ;temporary global array 145 ; used in ECXPLBB (pre-extract audit report) 146 Q 147 ; 148 GETDFN(ECXLRDFN) ; 149 ; INPUT - LRDFN 150 ; OUTPUT - DFN 151 ; Obtains DFN (Patient ID) from LRDFN (Lab Patient ID). 152 ; If no valid DFN exists, 0 is returned. 153 S ECXLRDFN=+$G(ECXLRDFN) 154 I $P($G(^LR(ECXLRDFN,0)),"^",2)'=2 Q 0 155 Q +$P(^LR(ECXLRDFN,0),"^",3) 156 ; 157 PAT(ECXDFN) ;get/set patient data 158 ; INPUT - ECXDFN = patient ien (DFN) 159 ; OUTPUT - ECPAT array: 160 ; ECPAT("SSN") 161 ; ECPAT("NAME") 162 ; returns 0 or 1 in ECXERR - 0=successful 163 ; 1=error condition 164 N X,OK,ECXERR 165 ;get data 166 S ECXERR=0 167 K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,"","1;3",.ECPAT) 168 I 'OK S ECXERR=1 169 Q ECXERR 170 ; 171 FILE(ECODE) ; 172 ; Input - ECODE = extract record 173 ; 174 ; record the extract record at a global node in file 727.829 175 ; sequence #^year/month of extract^extract #^facility^patient dfn^SSN^ 176 ; name^i/o pt indicator^encounter #^date of transfusion^time of 177 ; transfusion^component^component abbrev^# of units^volume in mm^ 178 ; reaction^reaction type^feeder location^DSS product dept^DSS IP # 179 ; ordering physician^ordering physician pc^emergency response indicator 180 ; (FEMA)^unit modified^unit modification^requesting provider^request. 181 ; provider person class 182 ;note: DSS product dept and DSS IP # are dependent on the release of 183 ; ECX*3*61 184 N DA,DIK,EC7 185 S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 186 S ECODE=EC7_"^"_ECODE 187 S ^ECX(ECFILE,EC7,0)=ECODE,ECRN=ECRN+1 188 S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA 189 Q 190 ; 191 ; 192 SETUP ;Set required input for ECXTRAC. 193 S ECHEAD="LBB" 194 D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) 195 Q 196 ; 197 LOCAL ; to extract nightly for local use not to be transmitted to TSI 198 ; should be queued with a 1D frequency 199 D SETUP,^ECXTLOCL,^ECXKILL Q 200 ; 201 QUE ; entry point for the background requeuing handled by ECXTAUTO 202 D SETUP,QUE^ECXTAUTO,^ECXKILL 203 Q 204 ; 205 ;ECXLBB -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXMOV.m
r613 r623 1 ECXMOV ;ALB/JAP,BIR/DMA,PTD-Transfer and Discharge Extract ; 6/6/07 6:46am 2 ;;3.0;DSS EXTRACTS;**8,24,33,39,41,42,46,65,84,107,105**;Dec 22, 1997;Build 70 3 BEG ;entry point from option 4 D SETUP I ECFILE="" Q 5 D ^ECXTRAC,^ECXKILL 6 Q 7 ; 8 START ; start package specific extract 9 N ECXDSC,W,WTO,X1,X2,X,ECXDPRPC,ECXDAPPC 10 K ECXDD D FIELD^DID(405,.19,,"SPECIFIER","ECXDD") 11 S ECPRO=$E(+$P(ECXDD("SPECIFIER"),"P",2)) K ECXDD 12 S ECED=ECED+.3,QFLG=0 13 F ECM=2,3 S ECARG="ATT"_ECM,ECD=ECSD1 D Q:QFLG 14 .F S ECD=$O(^DGPM(ECARG,ECD)),ECDA=0 Q:('ECD)!(ECD>ECED) D Q:QFLG 15 ..F S ECDA=$O(^DGPM(ECARG,ECD,ECDA)) Q:'ECDA D Q:QFLG 16 ...Q:'$D(^DGPM(ECDA,0)) S EC=^(0) 17 ...S ECXDFN=+$P(EC,U,3),ECMT=$P(EC,U,18),ECXDATE=ECD 18 ...K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECXDATE,"."),"1;",.ECXPAT) 19 ...I 'OK K ECXPAT Q 20 ...S ECXPNM=ECXPAT("NAME"),ECXSSN=ECXPAT("SSN"),ECXMPI=ECXPAT("MPI") 21 ...S ECTM=$$ECXTIME^ECXUTL(ECD) 22 ...S WTO=$P(EC,U,6),ECXWTO=$P($G(^DIC(42,+WTO,44)),U) 23 ...; 24 ...;reset EC to admission movement 25 ...S ECCA=$P(EC,U,14),EC=^DGPM(ECCA,0),ECA=$P(EC,U) 26 ...; 27 ...;if date of previous xfer movement is greater than admit date, 28 ...;then reset EC to that previous xfer movement 29 ...S ECDL=9999999.9999999-ECD,ECDL=+$O(^DGPM("ATID2",ECXDFN,ECDL)) 30 ...S ECDAL=+$O(^DGPM("ATID2",ECXDFN,ECDL,0)) 31 ...I $D(^DGPM(ECDAL,0)),$P(^(0),U)>$P(EC,U) S EC=^(0) 32 ...; 33 ...I ECM=2 D 34 ....;if transact=Transfer,ECD (time)=ASIH (7chars) and >0,set ECXDATE 35 ....;to Admit DT/time before calling funct to get in/out stat & TS 36 ....I $L($P(ECD,".",2))=7,+$E($P(ECD,".",2),7)>0 S ECXDATE=ECA 37 ....S W=$P(EC,U,6) 38 ...; 39 ...I ECM=3 D 40 ....;subtract 1 second from dischg DT so IN5^VADPT call (in ECXUTL2 41 ....;API) will pick up discharge movmement record 42 ....S ECXDATE=$$FMADD^XLFDT(ECXDATE,,,,-1) 43 ....;set losing ward to ward at discharge 44 ....N WARD S WARD=$$GET1^DIQ(405,ECDA,200) 45 ....I WARD'="" S W=+$O(^DIC(42,"B",WARD,0)) 46 ...; 47 ...;-Gets inpat/outpat status, DOM, Treating Spec (TS) 48 ...S X=$$INP^ECXUTL2(ECXDFN,ECXDATE),ECXA=$P(X,U),ECXDOM=$P(X,U,10),ECXTS=$P(X,U,3) 49 ...; 50 ...S (ECXWRD,ECXFAC,ECXDSSD)="" 51 ...I W'="" D 52 ....S ECXWRD=$P($G(^DIC(42,W,44)),U),ECXFAC=$P($G(^DIC(42,W,0)),U,11) 53 ....S ECXDSSD=$P($G(^ECX(727.4,W,0)),U,2) 54 ...S ECDI=$S(ECM=2:"",1:$$ECXDATE^ECXUTL(ECD,ECXYM)) 55 ...S X1=ECD,X2=$P(EC,U) D ^%DTC S ECXLOS=X 56 ...; 57 ...;- Get discharge PC Team, Primary and Assoc Primary Provider 58 ...S (ECXDPCT,ECXDPR,ECXDAPR,ECXDPRPC,ECXDAPPC)="" 59 ...I ECM=3 D 60 ....S ECXDSC=$$PRIMARY^ECXUTL2(ECXDFN,ECD) 61 ....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) 62 ....S ECDAPRNP=$P(ECXDSC,U,7),ECDPRNPI=$P(ECXDSC,U,4) 63 ...; 64 ...;Get production division ;p-46 65 ...N ECXPDIV S ECXPDIV=$$GETDIV^ECXDEPT(ECXFAC) ;p-46 66 ...;- Observation patient indicator (YES/NO) 67 ...S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS) 68 ...; 69 ...;- If no encounter number, don't file record 70 ...S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECA,,ECXTS,ECXOBS,ECHEAD,,) 71 ...D:ECXENC'="" FILE 72 Q 73 ; 74 FILE ;file the extract record 75 ;node0 76 ;fac ECXFAC^dfn ECXDFN^ssn ECXSSN^name ECXPNM^in/out ECXA^ 77 ;day (ECD)^^adm date (ECA)^disc date ECDI^mov # ECDA^ 78 ;type ECM^losing ward ECXWARD^treat spec ^los ECXLOS^^ 79 ;movement type ECMT^mov time ECTM^gaining ward ECXWTO^ 80 ;adm time (ECA)^^^ 81 ;node1 82 ;mpi ECXMPI^dss dept ECXDSSD^dom ECXDOM^observ pat ind ECXOBS^ 83 ;encounter num ECXENC^disch prim prov ECXDPR^disch PC team ECXDPCT^ 84 ;disch assoc prim prov ECXDAPR^production division ECXPDIV 85 ;^disch prov person class ECXDPRPC^disch assoc prov pe- 86 ;rson person class^disch assoc pc prov npi ECDAPRNP^discharge pc provider npi ECDPRNPI 87 N DA,DIK 88 S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 89 S ECODE=EC7_U_EC23_U_ECXFAC_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U 90 S ECODE=ECODE_$$ECXDATE^ECXUTL(ECD,ECXYM)_U_U 91 S ECODE=ECODE_$$ECXDATE^ECXUTL(ECA,ECXYM)_U_ECDI_U_ECDA_U_ECM_U_ECXWRD_U 92 S ECODE=ECODE_U_ECXLOS_U_U_ECMT_U_ECTM_U_ECXWTO_U 93 S ECODE=ECODE_$$ECXTIME^ECXUTL(ECA)_U_U_U 94 S ECODE1=ECXMPI_U_ECXDSSD_U_ECXDOM_U_ECXOBS_U_ECXENC_U_ECXDPR_U 95 S ECODE1=ECODE1_ECXDPCT_U_ECXDAPR_U_ECXPDIV ;p-46 added ECXPDIV 96 I ECXLOGIC>2005 S ECODE1=ECODE1_U_ECXDPRPC_U_ECXDAPPC 97 I ECXLOGIC>2007 S ECODE1=ECODE1_U_$G(ECDAPRNP)_U_$G(ECDPRNPI) 98 S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,ECRN=ECRN+1 99 S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA 100 I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 101 Q 102 ; 103 SETUP ;Set required input for ECXTRAC 104 S ECHEAD="MOV" 105 D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) 106 Q 107 ; 108 QUE ; entry point for the background requeuing handled by ECXTAUTO 109 D SETUP,QUE^ECXTAUTO,^ECXKILL Q 1 ECXMOV ;ALB/JAP,BIR/DMA,PTD-Transfer and Discharge Extract ; 8/19/05 9:13am 2 ;;3.0;DSS EXTRACTS;**8,24,33,39,41,42,46,65,84**;Dec 22, 1997 3 BEG ;entry point from option 4 D SETUP I ECFILE="" Q 5 D ^ECXTRAC,^ECXKILL 6 Q 7 ; 8 START ; start package specific extract 9 N ECXDSC,W,WTO,X1,X2,X,ECXDPRPC,ECXDAPPC 10 K ECXDD D FIELD^DID(405,.19,,"SPECIFIER","ECXDD") 11 S ECPRO=$E(+$P(ECXDD("SPECIFIER"),"P",2)) K ECXDD 12 S ECED=ECED+.3,QFLG=0 13 F ECM=2,3 S ECARG="ATT"_ECM,ECD=ECSD1 D Q:QFLG 14 .F S ECD=$O(^DGPM(ECARG,ECD)),ECDA=0 Q:('ECD)!(ECD>ECED) D Q:QFLG 15 ..F S ECDA=$O(^DGPM(ECARG,ECD,ECDA)) Q:'ECDA D Q:QFLG 16 ...Q:'$D(^DGPM(ECDA,0)) S EC=^(0) 17 ...S ECXDFN=+$P(EC,U,3),ECMT=$P(EC,U,18),ECXDATE=ECD 18 ...K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECXDATE,"."),"1;",.ECXPAT) 19 ...I 'OK K ECXPAT Q 20 ...S ECXPNM=ECXPAT("NAME"),ECXSSN=ECXPAT("SSN"),ECXMPI=ECXPAT("MPI") 21 ...S ECTM=$$ECXTIME^ECXUTL(ECD) 22 ...S WTO=$P(EC,U,6),ECXWTO=$P($G(^DIC(42,+WTO,44)),U) 23 ...; 24 ...;reset EC to admission movement 25 ...S ECCA=$P(EC,U,14),EC=^DGPM(ECCA,0),ECA=$P(EC,U) 26 ...; 27 ...;if date of previous xfer movement is greater than admit date, 28 ...;then reset EC to that previous xfer movement 29 ...S ECDL=9999999.9999999-ECD,ECDL=+$O(^DGPM("ATID2",ECXDFN,ECDL)) 30 ...S ECDAL=+$O(^DGPM("ATID2",ECXDFN,ECDL,0)) 31 ...I $D(^DGPM(ECDAL,0)),$P(^(0),U)>$P(EC,U) S EC=^(0) 32 ...; 33 ...I ECM=2 D 34 ....;if transact=Transfer,ECD (time)=ASIH (7chars) and >0,set ECXDATE 35 ....;to Admit DT/time before calling funct to get in/out stat & TS 36 ....I $L($P(ECD,".",2))=7,+$E($P(ECD,".",2),7)>0 S ECXDATE=ECA 37 ....S W=$P(EC,U,6) 38 ...; 39 ...I ECM=3 D 40 ....;subtract 1 second from dischg DT so IN5^VADPT call (in ECXUTL2 41 ....;API) will pick up discharge movmement record 42 ....S ECXDATE=$$FMADD^XLFDT(ECXDATE,,,,-1) 43 ....;set losing ward to ward at discharge 44 ....N WARD S WARD=$$GET1^DIQ(405,ECDA,200) 45 ....I WARD'="" S W=+$O(^DIC(42,"B",WARD,0)) 46 ...; 47 ...;-Gets inpat/outpat status, DOM, Treating Spec (TS) 48 ...S X=$$INP^ECXUTL2(ECXDFN,ECXDATE),ECXA=$P(X,U),ECXDOM=$P(X,U,10),ECXTS=$P(X,U,3) 49 ...; 50 ...S (ECXWRD,ECXFAC,ECXDSSD)="" 51 ...I W'="" D 52 ....S ECXWRD=$P($G(^DIC(42,W,44)),U),ECXFAC=$P($G(^DIC(42,W,0)),U,11) 53 ....S ECXDSSD=$P($G(^ECX(727.4,W,0)),U,2) 54 ...S ECDI=$S(ECM=2:"",1:$$ECXDATE^ECXUTL(ECD,ECXYM)) 55 ...S X1=ECD,X2=$P(EC,U) D ^%DTC S ECXLOS=X 56 ...; 57 ...;- Get discharge PC Team, Primary and Assoc Primary Provider 58 ...S (ECXDPCT,ECXDPR,ECXDAPR,ECXDPRPC,ECXDAPPC)="" 59 ...I ECM=3 D 60 ....S ECXDSC=$$PRIMARY^ECXUTL2(ECXDFN,ECD) 61 ....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) 62 ...; 63 ...;Get production division ;p-46 64 ...N ECXPDIV S ECXPDIV=$$GETDIV^ECXDEPT(ECXFAC) ;p-46 65 ...;- Observation patient indicator (YES/NO) 66 ...S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS) 67 ...; 68 ...;- If no encounter number, don't file record 69 ...S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECA,,ECXTS,ECXOBS,ECHEAD,,) 70 ...D:ECXENC'="" FILE 71 Q 72 ; 73 FILE ;file the extract record 74 ;node0 75 ;fac ECXFAC^dfn ECXDFN^ssn ECXSSN^name ECXPNM^in/out ECXA^ 76 ;day (ECD)^^adm date (ECA)^disc date ECDI^mov # ECDA^ 77 ;type ECM^losing ward ECXWARD^treat spec ^los ECXLOS^^ 78 ;movement type ECMT^mov time ECTM^gaining ward ECXWTO^ 79 ;adm time (ECA)^^^ 80 ;node1 81 ;mpi ECXMPI^dss dept ECXDSSD^dom ECXDOM^observ pat ind ECXOBS^ 82 ;encounter num ECXENC^disch prim prov ECXDPR^disch PC team ECXDPCT^ 83 ;disch assoc prim prov ECXDAPR^production division ECXPDIV 84 ;^disch prov person class ECXDPRPC^disch assoc prov pe- 85 ;rson person class 86 N DA,DIK 87 S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 88 S ECODE=EC7_U_EC23_U_ECXFAC_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U 89 S ECODE=ECODE_$$ECXDATE^ECXUTL(ECD,ECXYM)_U_U 90 S ECODE=ECODE_$$ECXDATE^ECXUTL(ECA,ECXYM)_U_ECDI_U_ECDA_U_ECM_U_ECXWRD_U 91 S ECODE=ECODE_U_ECXLOS_U_U_ECMT_U_ECTM_U_ECXWTO_U 92 S ECODE=ECODE_$$ECXTIME^ECXUTL(ECA)_U_U_U 93 S ECODE1=ECXMPI_U_ECXDSSD_U_ECXDOM_U_ECXOBS_U_ECXENC_U_ECXDPR_U 94 S ECODE1=ECODE1_ECXDPCT_U_ECXDAPR_U_ECXPDIV ;p-46 added ECXPDIV 95 I ECXLOGIC>2005 S ECODE1=ECODE1_U_ECXDPRPC_U_ECXDAPPC 96 S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,ECRN=ECRN+1 97 S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA 98 I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 99 Q 100 ; 101 SETUP ;Set required input for ECXTRAC 102 S ECHEAD="MOV" 103 D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) 104 Q 105 ; 106 QUE ; entry point for the background requeuing handled by ECXTAUTO 107 D SETUP,QUE^ECXTAUTO,^ECXKILL Q -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXMTL.m
r613 r623 1 ECXMTL ;ALB/JAP - DSS Mental Health Extract ; 8/17/07 9:52am 2 ;;3.0;DSS EXTRACTS;**24,30,33,39,46,49,71,82,84,92,105**;Dec 22, 1997;Build 70 3 ; 4 BEG ;entry point from option 5 D SETUP I ECFILE="" Q 6 D ^ECXTRAC,^ECXKILL 7 Q 8 ; 9 START ;entry point from tasked job 10 S QFLG=0 11 ;get first record # 12 S EC7=$O(^ECX(ECFILE,999999999),-1) 13 ;call mh/dss api for extract record creation 14 ;variables ecfile,ecxym,ecinst,ecsd,eced passed in by taskmanager 15 S ECXSEQ=EC7,ECXECX=$P(EC23,U,2),ECXERR=0 16 ;call mh api to create extract records 17 S X="YSDSS" X ^%ZOSF("TEST") I '$T S QFLG=1 Q 18 D UPD^YSDSS(ECFILE,.ECXSEQ,ECXYM,ECXECX,ECINST,ECSD,ECED,.ECXERR) 19 Q:ECXERR 20 Q:QFLG 21 ;if no error, continue 22 D UPDATE 23 Q 24 ; 25 UPDATE ;add non-mh data to each record created by mh api 26 N ECXADT,JJ,ECXNPRFI 27 S EC7=EC7+1 28 F JJ=EC7:1:ECXSEQ Q:QFLG D 29 .Q:'$D(^ECX(ECFILE,JJ,0)) 30 .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) 31 .S ECXSCNUM=$P(^ECX(ECFILE,JJ,0),U,23),ECXSCNAM=$P(^ECX(ECFILE,JJ,0),U,24) 32 .D PAT(ECXDFN,ECXDATE) 33 .S (ECXPRCLS,ECPRNPI,ECXDIV,ECXPDIV)="" I ECXPRV D PROV(.ECXPRV,ECXDATE) 34 .S ECXDSSI="" 35 .I ECXLOGIC>2003 D 36 ..I "^18^23^24^36^41^65^94^"[("^"_ECXTS_"^") S ECXDSSI=$$TSMAP^ECXUTL4(ECXTS) 37 .; 38 .;- Observation patient indicator (YES/NO) 39 .S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXDSSI) 40 .; 41 .;- set national patient record flag if exist 42 .D NPRF^ECXUTL5 43 .; 44 .;- If no encounter number don't file record 45 .S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADT,ECXDATE,ECXTS,ECXOBS,ECHEAD,,) Q:ECXENC="" 46 .S ECD=ECXDATE,ECXDATE=$$ECXDATE^ECXUTL(ECXDATE,ECXYM) 47 .;adjust scale name & scale number 48 .S ECXSCNAM=$E(ECXSCNAM,1,10) 49 .I ECXSCNUM]"",ECXSCNUM'=+ECXSCNUM S ECXSCNUM=+$E(ECXSCNUM,2,99) 50 .N ECXDEPT S ECXDEPT="" ;dss department use postponed S ECXDEPT=$$MTL^ECXDEPT(ECXDIV,ECXSCNAM,ECINST) ;p-46 line added 51 .;Set division to external value if extract is for FY05 or higher 52 .D FILE 53 Q 54 ; 55 PAT(ECXDFN,ECXDATE) ;determine in/outpatient status, demographics, primary care 56 N OK 57 S (ECXADT,ECXPNM,ECXSSN,ECXMPI)="" 58 K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,ECXDATE,"1;3;5;",.ECXPAT) 59 S ECXPNM=ECXPAT("NAME"),ECXSSN=ECXPAT("SSN"),ECXMPI=ECXPAT("MPI") 60 S ECXDOB=ECXPAT("DOB") 61 ;agent orange status 62 S ECXAST=ECXPAT("AO STAT") 63 ;- Purple Heart Indicator, Period of Service, Agent Orange Location 64 S ECXPHI=$G(ECXPAT("PHI")),ECXPOS=ECXPAT("POS"),ECXAOL=ECXPAT("AOL") 65 I $$ENROLLM^ECXUTL2(ECXDFN) 66 ;Combat Veteran Status 67 S X3=$$CVEDT^ECXUTL5(ECXDFN,$S($G(ECD):ECD,$G(ECXDATE):ECXDATE,1:DT)) 68 ; - Head and Neck Cancer Indicator 69 S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) 70 ; - Race and Ethnicity 71 S ECXETH=ECXPAT("ETHNIC") 72 S ECXRC1=ECXPAT("RACE1") 73 ;get primary care data 74 S X=$$PRIMARY^ECXUTL2(ECXDFN,ECXDATE),ECPTTM=$P(X,U) 75 S ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4) 76 S ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7) 77 ;get inpatient data 78 S X=$$INP^ECXUTL2(ECXDFN,ECXDATE),ECXDOM=$P(X,U,10),ECXTS=$P(X,U,3) 79 S ECXA=$P(X,U),(ECXADT,ECXADMDT)=$P($P(X,U,4),"."),ECXDCDT=$P($P(X,U,6),".") 80 S ECXWPRV=$P(X,U,7),ECXATT=$P(X,U,8) 81 S ECWPRNPI=$$NPI^XUSNPI("Individual_ID",ECXWPRV,ECXDATE) 82 S:+ECWPRNPI'>0 ECWPRNPI="" S ECWPRNPI=$P(ECWPRNPI,U) 83 S ECATTNPI=$$NPI^XUSNPI("Individual_ID",ECXATT,ECXDATE) 84 S:+ECATTNPI'>0 ECATTNPI="" S ECATTNPI=$P(ECATTNPI,U) 85 ;Get ward provider and attending phy person classes 86 S ECXWPRPC=$P(X,U,11),ECXATTPC=$P(X,U,12) 87 I ECXADMDT S ECXADMDT=$$ECXDATE^ECXUTL(ECXADMDT,ECXYM) 88 I ECXDCDT S ECXDCDT=$$ECXDATE^ECXUTL(ECXDCDT,ECXYM) 89 Q 90 ; 91 PROV(ECXPRV,ECXDATE) ;get provider data 92 N INST,DGIEN,ARR,DIC,DR,DA,DIQ 93 S ECXPRCLS=$$PRVCLASS^ECXUTL(ECXPRV,ECXDATE) 94 S ECPRNPI=$$NPI^XUSNPI("Individual_ID",ECXPRV,ECXDATE) 95 S:+ECPRNPI'>0 ECPRNPI="" S ECPRNPI=$P(ECPRNPI,U) 96 ;get division identifier using provider 97 S (ECXDIV,ECXPDIV)="" 98 S IEN=0 F D Q:'IEN Q:'INST Q:ECXDIV 99 .;get pointer to file #4 from provider record 100 .I '$D(^VA(200,ECXPRV,0)) Q 101 .S IEN=$O(^VA(200,ECXPRV,2,IEN)) 102 .Q:'IEN 103 .S DIC="^VA(200,",DR="16",DA=ECXPRV 104 .S DR(200.02)=".01",DA(200.02)=IEN,DIQ="ARR",DIQ(0)="I" 105 .D EN^DIQ1 106 .S INST=$G(ARR(200.02,IEN,.01,"I")) 107 .Q:'INST 108 .;get production division 109 .S ECXPDIV=$$RADDIV^ECXDEPT(INST) ;p-46 line added 110 .;get medical center division 111 .S DGIEN=$O(^DG(40.8,"AD",INST,0)) I DGIEN D 112 ..S ECXDIV=$P($G(^ECX(727.3,DGIEN,0)),U,2) 113 S ECXPRV="2"_ECXPRV 114 Q 115 ; 116 FILE ;file record in #727.812 117 ;node0 118 ;facility^dfn^ssn ECXSSN^name ECXPNM^i/o status ECXA^ 119 ;day ECXDATE^division ECXDIV^admit date ECXADMDT^ 120 ;d/c date ECXDCDT^dss id ECXDSSI^pc team ECPTTM^pc provider ECPTPR^ 121 ;placeholder^pc prov person class ECCLAS^ 122 ;provider ECXPRV^placeholder^prov person class ECXPRCLS^ 123 ;test name ECXSCNAM(?)^test ien ECXSCNUM(?)^scale number^scale name^ 124 ;test score^scale score^attend phys^ward provider 125 ;node1 126 ;mpi^assoc pc provider^placeholder^ 127 ;assoc pc prov person class^asi class^asi special^asi encounter date^ 128 ;purple heart ind.^dom prrtp & saartp ind.^enrollment cat^ 129 ;enrollment stat^enrollment prior^period of serv.^obs. pat ind.^ 130 ;encounter num^agent orange loc^dob^production division^dss 131 ;department ECXDEPT^head & neck canc. indi.^ethnicity^race1^^ 132 ;enrollment prior ECXPRIOR_enrollment subgroup 133 ;ECXSBGRP^enrollee user ECXUESTA^division ECXDIV^patient type 134 ;ECXPTYPE^combat vet elig ECXCVE^combat vet elig end date ECXCVEDT^ 135 ;enc cv eligible ECXCVENC^national patient record flag ECXNPRFI 136 ;attending phy person class ECXATTPC^ward provider person class 137 ;ECXWPRPC^^agent orange status ECXAST^asso prov npi ECASNPI^att phy 138 ;npi ECATTNPI^primary care prov npi ECPTNPI^provider npi ECPRNPI^ward 139 ;provider npi ECWPRNPI 140 N DA,DIK,STR 141 I $P(^ECX(ECFILE,JJ,0),U,21)="ASI" S $P(^ECX(ECFILE,JJ,1),U,7)=ECXDATE 142 S $P(^ECX(ECFILE,JJ,0),U,6,9)=ECXSSN_U_ECXPNM_U_ECXA_U_ECXDATE 143 S STR=$S(ECXLOGIC<2005:ECXDIV,1:"")_U_ECXADMDT_U_ECXDCDT_U_ECXDSSI_U_ECPTTM_U_ECPTPR_U 144 S STR=STR_U_ECCLAS,$P(^ECX(ECFILE,JJ,0),U,10,17)=STR,STR="" 145 S $P(^ECX(ECFILE,JJ,0),U,18,20)=ECXPRV_U_U_ECXPRCLS 146 S $P(^ECX(ECFILE,JJ,0),U,23,24)=ECXSCNUM_U_ECXSCNAM 147 S $P(^ECX(ECFILE,JJ,0),U,27,29)=ECXATT_U_ECXWPRV_U 148 I '$D(^ECX(ECFILE,JJ,1)) S ^ECX(727.812,JJ,1)="^^^^^" 149 S $P(^ECX(ECFILE,JJ,1),U,1,4)=ECXMPI_U_ECASPR_U_U_ECCLAS2 150 S STR=ECXPHI_U_ECXDOM_U_ECXCAT_U_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXPOS_U 151 S STR=STR_ECXOBS_U_ECXENC_U_ECXAOL_U_ECXDOB_U_ECXPDIV_U_ECXDEPT_U 152 S STR=STR_ECXHNCI_U_ECXETH_U_ECXRC1_U 153 I ECXLOGIC>2004 S STR=STR_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXDIV_U_ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXNPRFI 154 I ECXLOGIC>2005 S STR=STR_U_ECXATTPC_U_ECXWPRPC 155 S $P(^ECX(ECFILE,JJ,1),U,8,22)=STR 156 I ECXLOGIC>2006 S $P(^ECX(ECFILE,JJ,1),U,34)=ECXAST_U 157 I ECXLOGIC>2007 S $P(^ECX(ECFILE,JJ,1),U,35)=ECASNPI_U_ECATTNPI_U_ECPTNPI_U D 158 . S ^ECX(ECFILE,JJ,2)=ECPRNPI_U_ECWPRNPI 159 S DA=JJ,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA 160 S ECRN=ECRN+1 161 I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 162 Q 163 ; 164 SETUP ;Set required input for ECXTRAC 165 S ECHEAD="MTL" 166 D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) 167 Q 168 ; 169 QUE ;Entry point for the background requeuing handled by ECXTAUTO. 170 D SETUP,QUE^ECXTAUTO,^ECXKILL 171 Q 1 ECXMTL ;ALB/JAP - DSS Mental Health Extract ; 9/11/06 11:07am 2 ;;3.0;DSS EXTRACTS;**24,30,33,39,46,49,71,82,84,92**;Dec 22, 1997;Build 30 3 ; 4 BEG ;entry point from option 5 D SETUP I ECFILE="" Q 6 D ^ECXTRAC,^ECXKILL 7 Q 8 ; 9 START ;entry point from tasked job 10 S QFLG=0 11 ;get first record # 12 S EC7=$O(^ECX(ECFILE,999999999),-1) 13 ;call mh/dss api for extract record creation 14 ;variables ecfile,ecxym,ecinst,ecsd,eced passed in by taskmanager 15 S ECXSEQ=EC7,ECXECX=$P(EC23,U,2),ECXERR=0 16 ;call mh api to create extract records 17 S X="YSDSS" X ^%ZOSF("TEST") I '$T S QFLG=1 Q 18 D UPD^YSDSS(ECFILE,.ECXSEQ,ECXYM,ECXECX,ECINST,ECSD,ECED,.ECXERR) 19 Q:ECXERR 20 Q:QFLG 21 ;if no error, continue 22 D UPDATE 23 Q 24 ; 25 UPDATE ;add non-mh data to each record created by mh api 26 N ECXADT,JJ,ECXNPRFI 27 S EC7=EC7+1 28 F JJ=EC7:1:ECXSEQ Q:QFLG D 29 .Q:'$D(^ECX(ECFILE,JJ,0)) 30 .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) 31 .S ECXSCNUM=$P(^ECX(ECFILE,JJ,0),U,23),ECXSCNAM=$P(^ECX(ECFILE,JJ,0),U,24) 32 .D PAT(ECXDFN,ECXDATE) 33 .S (ECXPRCLS,ECXPRNPI,ECXDIV,ECXPDIV)="" I ECXPRV D PROV(.ECXPRV,ECXDATE) 34 .S ECXDSSI="" 35 .I ECXLOGIC>2003 D 36 ..I "^18^23^24^36^41^65^94^"[("^"_ECXTS_"^") S ECXDSSI=$$TSMAP^ECXUTL4(ECXTS) 37 .; 38 .;- Observation patient indicator (YES/NO) 39 .S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXDSSI) 40 .; 41 .;- set national patient record flag if exist 42 .D NPRF^ECXUTL5 43 .; 44 .;- If no encounter number don't file record 45 .S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADT,ECXDATE,ECXTS,ECXOBS,ECHEAD,,) Q:ECXENC="" 46 .S ECD=ECXDATE,ECXDATE=$$ECXDATE^ECXUTL(ECXDATE,ECXYM) 47 .;adjust scale name & scale number 48 .S ECXSCNAM=$E(ECXSCNAM,1,10) 49 .I ECXSCNUM]"",ECXSCNUM'=+ECXSCNUM S ECXSCNUM=+$E(ECXSCNUM,2,99) 50 .N ECXDEPT S ECXDEPT="" ;dss department use postponed S ECXDEPT=$$MTL^ECXDEPT(ECXDIV,ECXSCNAM,ECINST) ;p-46 line added 51 .;Set division to external value if extract is for FY05 or higher 52 .D FILE 53 Q 54 ; 55 PAT(ECXDFN,ECXDATE) ;determine in/outpatient status, demographics, primary care 56 N OK 57 S (ECXADT,ECXPNM,ECXSSN,ECXMPI)="" 58 K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,ECXDATE,"1;3;5;",.ECXPAT) 59 S ECXPNM=ECXPAT("NAME"),ECXSSN=ECXPAT("SSN"),ECXMPI=ECXPAT("MPI") 60 S ECXDOB=ECXPAT("DOB") 61 ;agent orange status 62 S ECXAST=ECXPAT("AO STAT") 63 ;- Purple Heart Indicator, Period of Service, Agent Orange Location 64 S ECXPHI=$G(ECXPAT("PHI")),ECXPOS=ECXPAT("POS"),ECXAOL=ECXPAT("AOL") 65 I $$ENROLLM^ECXUTL2(ECXDFN) 66 ;Combat Veteran Status 67 S X3=$$CVEDT^ECXUTL5(ECXDFN,$S($G(ECD):ECD,$G(ECXDATE):ECXDATE,1:DT)) 68 ; - Head and Neck Cancer Indicator 69 S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) 70 ; - Race and Ethnicity 71 S ECXETH=ECXPAT("ETHNIC") 72 S ECXRC1=ECXPAT("RACE1") 73 ;get primary care data 74 S X=$$PRIMARY^ECXUTL2(ECXDFN,ECXDATE),ECPTTM=$P(X,U) 75 S ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4) 76 S ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7) 77 ;get inpatient data 78 S X=$$INP^ECXUTL2(ECXDFN,ECXDATE),ECXDOM=$P(X,U,10),ECXTS=$P(X,U,3) 79 S ECXA=$P(X,U),(ECXADT,ECXADMDT)=$P($P(X,U,4),"."),ECXDCDT=$P($P(X,U,6),".") 80 S ECXWPRV=$P(X,U,7),ECXATT=$P(X,U,8) 81 ;Get ward provider and attending phy person classes 82 S ECXWPRPC=$P(X,U,11),ECXATTPC=$P(X,U,12) 83 I ECXADMDT S ECXADMDT=$$ECXDATE^ECXUTL(ECXADMDT,ECXYM) 84 I ECXDCDT S ECXDCDT=$$ECXDATE^ECXUTL(ECXDCDT,ECXYM) 85 Q 86 ; 87 PROV(ECXPRV,ECXDATE) ;get provider data 88 N INST,DGIEN,ARR,DIC,DR,DA,DIQ 89 S ECXPRCLS=$$PRVCLASS^ECXUTL(ECXPRV,ECXDATE) 90 S ECXPRNPI="" 91 ;get division identifier using provider 92 S (ECXDIV,ECXPDIV)="" 93 S IEN=0 F D Q:'IEN Q:'INST Q:ECXDIV 94 .;get pointer to file #4 from provider record 95 .I '$D(^VA(200,ECXPRV,0)) Q 96 .S IEN=$O(^VA(200,ECXPRV,2,IEN)) 97 .Q:'IEN 98 .S DIC="^VA(200,",DR="16",DA=ECXPRV 99 .S DR(200.02)=".01",DA(200.02)=IEN,DIQ="ARR",DIQ(0)="I" 100 .D EN^DIQ1 101 .S INST=$G(ARR(200.02,IEN,.01,"I")) 102 .Q:'INST 103 .;get production division 104 .S ECXPDIV=$$RADDIV^ECXDEPT(INST) ;p-46 line added 105 .;get medical center division 106 .S DGIEN=$O(^DG(40.8,"AD",INST,0)) I DGIEN D 107 ..S ECXDIV=$P($G(^ECX(727.3,DGIEN,0)),U,2) 108 S ECXPRV="2"_ECXPRV 109 Q 110 ; 111 FILE ;file record in #727.812 112 ;node0 113 ;facility^dfn^ssn ECXSSN^name ECXPNM^i/o status ECXA^ 114 ;day ECXDATE^division ECXDIV^admit date ECXADMDT^ 115 ;d/c date ECXDCDT^dss id ECXDSSI^pc team ECPTTM^pc provider ECPTPR^ 116 ;pc provider npi ECPTNPI^pc prov person class ECCLAS^ 117 ;provider ECXPRV^provider npi ECXPRNPI^prov person class ECXPRCLS^ 118 ;test name ECXSCNAM(?)^test ien ECXSCNUM(?)^scale number^scale name^ 119 ;test score^scale score^attend phys^ward provider 120 ;node1 121 ;mpi^assoc pc provider^assoc pc provider npi^ 122 ;assoc pc prov person class^asi class^asi special^asi encounter date^ 123 ;purple heart ind.^dom prrtp & saartp ind.^enrollment cat^ 124 ;enrollment stat^enrollment prior^period of serv.^obs. pat ind.^ 125 ;encounter num^agent orange loc^dob^production division^dss 126 ;department ECXDEPT^head & neck canc. indi.^ethnicity^race1^^ 127 ;enrollment prior ECXPRIOR_enrollment subgroup 128 ;ECXSBGRP^enrollee user ECXUESTA^division ECXDIV^patient type 129 ;ECXPTYPE^combat vet elig ECXCVE^combat vet elig end date ECXCVEDT^ 130 ;enc cv eligible ECXCVENC^national patient record flag ECXNPRFI 131 ;attending phy person class ECXATTPC^ward provider person class 132 ;ECXWPRPC^^agent orange status ECXAST 133 N DA,DIK,STR 134 I $P(^ECX(ECFILE,JJ,0),U,21)="ASI" S $P(^ECX(ECFILE,JJ,1),U,7)=ECXDATE 135 S $P(^ECX(ECFILE,JJ,0),U,6,9)=ECXSSN_U_ECXPNM_U_ECXA_U_ECXDATE 136 S STR=$S(ECXLOGIC<2005:ECXDIV,1:"")_U_ECXADMDT_U_ECXDCDT_U_ECXDSSI_U_ECPTTM_U_ECPTPR_U 137 S STR=STR_ECPTNPI_U_ECCLAS,$P(^ECX(ECFILE,JJ,0),U,10,17)=STR,STR="" 138 S $P(^ECX(ECFILE,JJ,0),U,18,20)=ECXPRV_U_ECXPRNPI_U_ECXPRCLS 139 S $P(^ECX(ECFILE,JJ,0),U,23,24)=ECXSCNUM_U_ECXSCNAM 140 S $P(^ECX(ECFILE,JJ,0),U,27,29)=ECXATT_U_ECXWPRV_U 141 I '$D(^ECX(ECFILE,JJ,1)) S ^ECX(727.812,JJ,1)="^^^^^" 142 S $P(^ECX(ECFILE,JJ,1),U,1,4)=ECXMPI_U_ECASPR_U_ECASNPI_U_ECCLAS2 143 S STR=ECXPHI_U_ECXDOM_U_ECXCAT_U_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXPOS_U 144 S STR=STR_ECXOBS_U_ECXENC_U_ECXAOL_U_ECXDOB_U_ECXPDIV_U_ECXDEPT_U 145 S STR=STR_ECXHNCI_U_ECXETH_U_ECXRC1_U 146 I ECXLOGIC>2004 S STR=STR_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXDIV_U_ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXNPRFI 147 I ECXLOGIC>2005 S STR=STR_U_ECXATTPC_U_ECXWPRPC 148 S $P(^ECX(ECFILE,JJ,1),U,8,22)=STR 149 I ECXLOGIC>2006 S $P(^ECX(ECFILE,JJ,1),U,34)=ECXAST 150 S DA=JJ,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA 151 S ECRN=ECRN+1 152 I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 153 Q 154 ; 155 SETUP ;Set required input for ECXTRAC 156 S ECHEAD="MTL" 157 D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) 158 Q 159 ; 160 QUE ;Entry point for the background requeuing handled by ECXTAUTO. 161 D SETUP,QUE^ECXTAUTO,^ECXKILL 162 Q -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXNUT.m
r613 r623 1 ECXNUT ;ALB/JRC Nutrition DSS Extract ; 9/24/07 9:33am 2 ;;3.0;DSS EXTRACTS;**92,107,105**;Dec 22, 1997;Build 70 3 BEG ;entry point from option 4 N EC23,EC7,ECED,ECFILE,ECGRP,ECHEAD,ECINST,ECPACK,ECPIECE,ECRN,ECRTN,ECSD1,ECVER,ECXYM 5 D SETUP I ECFILE="" Q 6 D ^ECXTRAC,^ECXKILL 7 Q 8 ; 9 START ; start package specific extract 10 ;Init variables 11 N ECSD,ARRAY 12 S ECED=ECED+.3,ECSD=ECSD1,ARRAY="^TMP($J,""FH"")" 13 K @ARRAY 14 ; 15 ;Call n&fs api and store in ^TMP($J,"FH" global 16 D DATA^FHDSSAPI(ECSD,ECED) 17 ; 18 ;Get n&fs records from ^TMP($J,"FH" global and file 19 D GETMEALS^ECXNUT1 20 ; 21 ;kill ^tmp global 22 K @ARRAY 23 ; 24 Q 25 ; 26 GET ;gather extract data 27 ;Init variables 28 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 29 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 30 N ECXOEF,ECXOEFDT 31 ; 32 ;- Prefix ordering pro with a 2 and get person class 33 S ECXORDPC=$$PRVCLASS^ECXUTL(+ECXORDPH,DATE) 34 S ECORNPI=$$NPI^XUSNPI("Individual_ID",+ECXORDPH,DATE) 35 S:+ECORNPI'>0 ECORNPI="" S ECORNPI=$P(ECORNPI,U) 36 S ECXORDPH=$S(ECXORDPH:2_ECXORDPH,1:"") 37 ; 38 ;set patient file (#2) dfn and get patient demographics 39 S ECXDFN=$P($G(^TMP($J,"FH","ZN",FHDFN)),U,3) 40 S ECXERR=0 D PAT(ECXDFN) 41 Q:ECXERR 42 ;Set demographic variables 43 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") 44 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") 45 S ECXPOS=ECPAT("POS"),ECXAST=ECPAT("AO STAT"),ECXAOL=ECPAT("AOL"),ECXRST=ECPAT("IR STAT"),ECXEST=ECPAT("EC STAT") 46 ; 47 ;Get oef/oif data 48 S ECXOEF=ECPAT("ECXOEF") 49 S ECXOEFDT=ECPAT("ECXOEFDT") 50 ; 51 ;Get enrollment status 52 I $$ENROLLM^ECXUTL2(ECXDFN) 53 ; 54 S ECXTM=$$ECXTIME^ECXUTL(DATE) 55 S ECXDATE=$$ECXDATE^ECXUTL(+DATE,ECXYM) 56 ; 57 ;- Use movement record date & time 58 S ADM=$$INP^ECXUTL2(ECXDFN,DATE),ECXA=$P(ADM,U) 59 S ECXMN=$P(ADM,U,2),ECXSPC=$P(ADM,U,3),ECXADMDT=$P(ADM,U,4) 60 S W=$P(ADM,U,9),ECXWRD=$P(W,";",1),ECXFAC=$P(W,";",2) 61 S ECXPRV=$P(ADM,U,7),ECXPRNPI="",ECXATT=$P(ADM,U,8),ECXATNPI="" 62 S ECXDOM=$P(ADM,U,10),ECXATTPC=$P(ADM,U,12),ECXPRVPC=$P(ADM,U,11) 63 ; 64 S ECXPDIV=$$GETDIV^ECXDEPT(ECXFAC) ;Get production division 65 S ECXCBOC=$$CBOC^ECXSCX2(+ECXFAC) ;Get cboc facility 66 ; 67 ;- Get primary care data 68 S X=$$PRIMARY^ECXUTL2(ECXDFN,DATE) 69 S ECPTPR=$P(X,U,2),ECCLASS=$P(X,U,3),ECPTTM=$P(X,U),ECPTNPI=$P(X,U,4) 70 ; 71 ;- Observation patient indicator (YES/NO) 72 S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXSPC) 73 ; 74 ;- Get head and neck cancer indicator 75 S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) 76 ; 77 ;- Get national patient record flag indicator 78 N ECXNPRFI D NPRF^ECXUTL5 79 ; 80 ;- National response indicator 81 S ECXERI=$$EMGRES^DGUTL(ECXDFN) 82 ; 83 ;- If null encounter number, don't file record 84 S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,DATE,ECXSPC,ECXOBS,ECHEAD,,) 85 D:ECXENC'="" FILE 86 Q 87 ; 88 PAT(ECXDFN) ;get/set patient data 89 ; INPUT - ECXDFN = patient ien (DFN) 90 ; OUTPUT - ECPAT array: 91 ; ECPAT("SSN") 92 ; ECPAT("NAME") 93 ; returns 0 or 1 in ECXERR - 0=successful 94 ; 1=error condition 95 N X,OK 96 ;get data 97 S ECXERR=0 98 K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,"","1;2;3;5",.ECPAT) 99 I 'OK S ECXERR=1 100 Q ECXERR 101 ; 102 FILE ;file the n&fs extract record 103 ;node 104 ;facility^dfn^ssn^name^in/out^day^time^treating specialty^ 105 ;ordering provider^ordering provider person class^primary 106 ;care provider^primary person class^primary care team^mpi^dob^sex^ 107 ;race 1^ethnicity^veteran^enrollment status^enrollment location^ 108 ;enrollment category^enrollment priority^eligibility^period of 109 ;service^agent orange status^agent orange location^radiation status 110 ;^environmental contaminants^mst status^head & neck cancer indicator 111 ;pow status^pow location^purple heart indicator^means test^state code 112 ;^county code^zip+4^observation patient indicator^rrtp,prrtp and 113 ;saartp indicator^encounter number^patient division^food production 114 ;division^delivery division^product feeder key^food production 115 ;facility^delivery location type^delivery feeder location^quantity^ 116 ;cboc^status^user enrollee^patient type^cv status eligibility^ 117 ;national patient record flag^emergency response indicator^admission 118 ;date^oef/oif ECXOEF^oef/oif return date ECXOEFDT^ordering provider 119 ;npi ECORNPI^primary care provider npi ECPTNPI 120 ; 121 N DA,DIK,ECODE,ECODE1 122 S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 123 S ECODE=EC7_U_EC23_U_ECINST_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U 124 ; 125 ;convert specialty to PTF Code 126 ; 127 N ECXDATA 128 S ECXDATA=$$TSDATA^DGACT(42.4,+ECXSPC,.ECXDATA) 129 S ECXSPC=$G(ECXDATA(7)) 130 ; 131 S ECODE=ECODE_ECXDATE_U_ECXTM_U_ECXSPC_U_ECXORDPH_U_ECXORDPC_U 132 S ECODE=ECODE_ECPTPR_U_ECCLASS_U_ECPTTM_U_ECXMPI_U_ECXDOB_U_ECXSEX_U 133 S ECODE=ECODE_ECXRC1_U_ECXETH_U_ECXVET_U_ECXSTAT_U_ECXENRL_U_ECXCAT_U 134 S ECODE=ECODE_ECXPRIOR_U_ECXELIG_U_ECXPOS_U_ECXAST_U_ECXAOL_U_ECXRST 135 S ECODE=ECODE_U_ECXEST_U_ECXMST_U_ECXHNCI_U_ECXPST_U_ECXPLOC_U_ECXPHI 136 S ECODE=ECODE_U_ECXMNS_U_ECXSTATE_U_ECXCNTY_U 137 S ECODE1=ECXZIP_U_ECXOBS_U_ECXDOM_U_ECXENC_U_ECXPDIV_U_ECXFPD_U 138 S ECODE1=ECODE1_ECXFDD_U_ECXKEY_U_ECXFPF_U_ECXDLT_U_ECXDFL_U_ECXQTY_U 139 S ECODE1=ECODE1_ECXCBOC_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U_ECXNPRFI_U 140 S ECODE1=ECODE1_ECXERI_U_$S(ECXADMDT:$$ECXDATE^ECXUTL(ECXADMDT,ECXYM),1:"") 141 I ECXLOGIC>2007 S ECODE1=ECODE1_U_ECXOEF_U_ECXOEFDT_U_$G(ECXTFU)_U_ECORNPI_U_ECPTNPI 142 S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1 143 S ECRN=ECRN+1 144 S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA 145 Q 146 ; 147 SETUP ;Set required input for ECXTRAC. 148 S ECHEAD="NUT" 149 D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) 150 Q 1 ECXNUT ;ALB/JRC Nutrition DSS Extract ; 4/2/2007 2 ;;3.0;DSS EXTRACTS;**92,107**;Dec 22, 1997;Build 9 3 BEG ;entry point from option 4 N EC23,EC7,ECED,ECFILE,ECGRP,ECHEAD,ECINST,ECPACK,ECPIECE,ECRN,ECRTN,ECSD1,ECVER,ECXYM 5 D SETUP I ECFILE="" Q 6 D ^ECXTRAC,^ECXKILL 7 Q 8 ; 9 START ; start package specific extract 10 ;Init variables 11 N ECSD 12 S ECED=ECED+.3,ECSD=ECSD1 13 K ^TMP($J,"FH") 14 ; 15 ;Call n&fs api and store in ^TMP($J,"FH" global 16 D DATA^FHDSSAPI(ECSD,ECED) 17 ; 18 ;Get n&fs records from ^TMP($J,"FH" global and file 19 D GETMEALS^ECXNUT1 20 ; 21 ;kill ^tmp global 22 K ^TMP($J,"FH") 23 ; 24 Q 25 ; 26 GET ;gather extract data 27 ;Init variables 28 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 29 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 30 ; 31 ;- Prefix ordering pro with a 2 and get person class 32 S ECXORDPC=$$PRVCLASS^ECXUTL(+ECXORDPH,DATE) 33 S ECXORDPH=$S(ECXORDPH:2_ECXORDPH,1:"") 34 ; 35 ;set patient file (#2) dfn and get patient demographics 36 S ECXDFN=$P($G(^TMP($J,"FH","ZN",FHDFN)),U,3) 37 S ECXERR=0 D PAT(ECXDFN) 38 Q:ECXERR 39 ;Set demographic variables 40 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") 41 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") 42 S ECXPOS=ECPAT("POS"),ECXAST=ECPAT("AO STAT"),ECXAOL=ECPAT("AOL"),ECXRST=ECPAT("IR STAT"),ECXEST=ECPAT("EC STAT") 43 ; 44 ;Get enrollment status 45 I $$ENROLLM^ECXUTL2(ECXDFN) 46 ; 47 S ECXTM=$$ECXTIME^ECXUTL(DATE) 48 S ECXDATE=DATE 49 ; 50 ;- Use movement record date & time 51 S ADM=$$INP^ECXUTL2(ECXDFN,DATE),ECXA=$P(ADM,U) 52 S ECXMN=$P(ADM,U,2),ECXSPC=$P(ADM,U,3),ECXADMDT=$P(ADM,U,4) 53 S W=$P(ADM,U,9),ECXWRD=$P(W,";",1),ECXFAC=$P(W,";",2) 54 S ECXPRV=$P(ADM,U,7),ECXPRNPI="",ECXATT=$P(ADM,U,8),ECXATNPI="" 55 S ECXDOM=$P(ADM,U,10),ECXATTPC=$P(ADM,U,12),ECXPRVPC=$P(ADM,U,11) 56 ; 57 S ECXPDIV=$$GETDIV^ECXDEPT(ECXFAC) ;Get production division 58 S ECXCBOC=$$CBOC^ECXSCX2(+ECXFAC) ;Get cboc facility 59 ; 60 ;- Get primary care data 61 S X=$$PRIMARY^ECXUTL2(ECXDFN,DATE) 62 S ECPTPR=$P(X,U,2),ECCLASS=$P(X,U,3),ECPTTM=$P(X,U) 63 ; 64 ;- Observation patient indicator (YES/NO) 65 S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXSPC) 66 ; 67 ;- Get head and neck cancer indicator 68 S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) 69 ; 70 ;- Get national patient record flag indicator 71 N ECXNPRFI D NPRF^ECXUTL5 72 ; 73 ;- National response indicator 74 S ECXERI=$$EMGRES^DGUTL(ECXDFN) 75 ; 76 ;- If null encounter number, don't file record 77 S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,DATE,ECXSPC,ECXOBS,ECHEAD,,) 78 D:ECXENC'="" FILE 79 Q 80 ; 81 PAT(ECXDFN) ;get/set patient data 82 ; INPUT - ECXDFN = patient ien (DFN) 83 ; OUTPUT - ECPAT array: 84 ; ECPAT("SSN") 85 ; ECPAT("NAME") 86 ; returns 0 or 1 in ECXERR - 0=successful 87 ; 1=error condition 88 N X,OK 89 ;get data 90 S ECXERR=0 91 K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,"","1;2;3;5",.ECPAT) 92 I 'OK S ECXERR=1 93 Q ECXERR 94 ; 95 FILE ;file the n&fs extract record 96 ;node 97 ;facility^dfn^ssn^name^in/out^day^time^treating specialty^ 98 ;ordering provider^ordering provider person class^primary 99 ;care provider^primary person class^primary care team^mpi^dob^sex^ 100 ;race 1^ethnicity^veteran^enrollment status^enrollment location^ 101 ;enrollment category^enrollment priority^eligibility^period of 102 ;service^agent orange status^agent orange location^radiation status 103 ;^environmental contaminants^mst status^head & neck cancer indicator 104 ;pow status^pow location^purple heart indicator^means test^state code 105 ;^county code^zip+4^observation patient indicator^rrtp,prrtp and 106 ;saartp indicator^encounter number^patient division^food production 107 ;division^delivery division^product feeder key^food production 108 ;facility^delivery location type^delivery feeder location^quantity^ 109 ;cboc^status^user enrollee^patient type^cv status eligibility^ 110 ;national^patient record flag^emergency response indicator^admission 111 ;date 112 ; 113 N DA,DIK,ECODE,ECODE1 114 S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 115 S ECODE=EC7_U_EC23_U_ECINST_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U 116 ; 117 ;convert specialty to PTF Code 118 ; 119 N ECXDATA 120 S ECXDATA=$$TSDATA^DGACT(42.4,+ECXSPC,.ECXDATA) 121 S ECXSPC=$G(ECXDATA(7)) 122 ; 123 S ECODE=ECODE_$$ECXDATE^ECXUTL(DATE,ECXYM)_U_ECXTM_U_ECXSPC_U_ECXORDPH_U_ECXORDPC_U 124 S ECODE=ECODE_ECPTPR_U_ECCLASS_U_ECPTTM_U_ECXMPI_U_ECXDOB_U_ECXSEX_U 125 S ECODE=ECODE_ECXRC1_U_ECXETH_U_ECXVET_U_ECXSTAT_U_ECXENRL_U_ECXCAT_U 126 S ECODE=ECODE_ECXPRIOR_U_ECXELIG_U_ECXPOS_U_ECXAST_U_ECXAOL_U_ECXRST 127 S ECODE=ECODE_U_ECXEST_U_ECXMST_U_ECXHNCI_U_ECXPST_U_ECXPLOC_U_ECXPHI 128 S ECODE=ECODE_U_ECXMNS_U_ECXSTATE_U_ECXCNTY_U 129 S ECODE1=ECXZIP_U_ECXOBS_U_ECXDOM_U_ECXENC_U_ECXPDIV_U_ECXFPD_U 130 S ECODE1=ECODE1_ECXFDD_U_ECXKEY_U_ECXFPF_U_ECXDLT_U_ECXDFL_U_ECXQTY_U 131 S ECODE1=ECODE1_ECXCBOC_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U_ECXNPRFI_U 132 S ECODE1=ECODE1_ECXERI_U_$S(ECXADMDT:$$ECXDATE^ECXUTL(ECXADMDT,ECXYM),1:"") 133 S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1 134 S ECRN=ECRN+1 135 S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA 136 Q 137 ; 138 SETUP ;Set required input for ECXTRAC. 139 S ECHEAD="NUT" 140 D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) 141 Q -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXNUT1.m
r613 r623 1 ECXNUT1 ;ALB/JRC Nutrition DSS Extract ; 11/23/07 12:27pm 2 ;;3.0;DSS EXTRACTS;**92,107,105**;Dec 22, 1997;Build 70 3 Q 4 GETMEALS ;get patient meals 5 ; variable names: ordate - regular diet order date 6 ; sdate - diet order npo/withhold date 7 ; norder - "sf" or "so" order date 8 ; note: there is a relationship 9 ; between "sf", "so" and regular diets 10 ; adate - admission date 11 ; ddate - discharge date 12 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 13 ;set ecsd to first day of the month before setting meals array 14 S ECSD=ECSD+.1,ECXTFU="" 15 ;setup individual meals array for inpatients 16 F I=ECSD:1:ECED F J=I+.0800,I+.1300,I+.1800 S MEALS(J)=J 17 ;get "inp", "sf", and "so" inpatient meals 18 S ECXADM=0 F S ECXADM=$O(@ARRAY@(ECXADM)) Q:'ECXADM D 19 .S FHDFN=0 F S FHDFN=$O(@ARRAY@(ECXADM,FHDFN)) Q:'FHDFN D 20 ..S ORDATE=0,(ADATE,DDATE,SDATE)="" 21 ..F S ORDATE=$O(@ARRAY@(ECXADM,FHDFN,ORDATE)) Q:'ORDATE D 22 ...Q:$P($G(^TMP($J,"FH",ECXADM,FHDFN,+ORDATE,"INP")),U,7)'="" 23 ...S DATES=$$GETDATES(),SDATE=ORDATE 24 ...;create regular diet individual meals 25 ...S P="INP",D="PD" 26 ...;get new order date and time if exist 27 ...S NORDER=$$NEWORDER(D,ORDATE) 28 ...S NODE=$G(^TMP($J,"FH",ECXADM,FHDFN,ORDATE,"INP")) Q:'NODE 29 ...S PRODUCT=$P(NODE,U,13),ECXQTY=1,ORDER=""_$P(NODE,U,14)_","_"" 30 ...;Resolve feeder key for nutrition product 31 ...S ECXKEY=$$NUTKEY^ECXUTL6(D,PRODUCT) 32 ...I $$NUTLOC^ECXUTL6(P,D,.ECXFPD,.ECXFDD,.ECXFPF,.ECXDLT,.ECXDFL) 33 ...S MEAL=ORDATE F S MEAL=$O(MEALS(MEAL)) Q:'MEAL D 34 ....I $P(DATES,U) Q:MEAL>$P(DATES,U) 35 ....I NORDER]"" Q:MEAL>NORDER 36 ....I $P(DATES,U,3) Q:MEAL>$P(DATES,U,3) 37 ....S ECXORDPH=$$GET1^DIQ(100,+ORDER,1,"I") 38 ....;Get additional data and file record. 39 ....S DATE=MEAL D GET^ECXNUT 40 ;create supplemental feeding meals if they exist 41 S ECXADM=0 F S ECXADM=$O(@ARRAY@(ECXADM)) Q:'ECXADM D 42 .S FHDFN=0 F S FHDFN=$O(@ARRAY@(ECXADM,FHDFN)) Q:'FHDFN D 43 ..S ORDATE=0,(ADATE,DDATE,SDATE)="" 44 ..F S ORDATE=$O(@ARRAY@(ECXADM,FHDFN,ORDATE)) Q:'ORDATE D 45 ...S DATES=$$GETDATES() 46 ...;get "sf" orders if they exist 47 ...N SFNODE S (SFNODE,ECXORDPH,CDATE)="" 48 ...S SFNODE=$G(@ARRAY@(ECXADM,FHDFN,ORDATE,"SF")) 49 ...I +SFNODE D 50 ....S P="INP",D="SF" 51 ....;get new order date and time if exist 52 ....S NORDER=$$NEWORDER(D,ORDATE),CDATE=$P(SFNODE,U,32) 53 ....;order thru all "sf" product fields and generate records 54 ....F SF=5:2:27 S PRODUCT=$P(SFNODE,U,SF) S ECXQTY=$P(SFNODE,U,(SF+1)) D 55 .....Q:PRODUCT']"" 56 .....;Resolve external value for product key 57 .....S ECXKEY=$$NUTKEY^ECXUTL6("SF",PRODUCT) 58 .....I $$NUTLOC^ECXUTL6(P,D,.ECXFPD,.ECXFDD,.ECXFPF,.ECXDLT,.ECXDFL) 59 .....;create individual meals 60 .....F MEAL=ECSD:1:ECED D 61 ......I CDATE]"" Q:MEAL>CDATE 62 ......I NORDER]"" Q:MEAL>NORDER 63 ......I $P(DATES,U,3)]"" Q:MEAL>$P(DATES,U,3) 64 ......;Get additional data and file record. 65 ......S DATE=$P(MEAL,".")_"."_$S("57911"[SF:10,"13151719"[SF:14,1:18) 66 ......D GET^ECXNUT 67 ;create standing order meals if they exist 68 S ECXADM=0 F S ECXADM=$O(@ARRAY@(ECXADM)) Q:'ECXADM D 69 .S FHDFN=0 F S FHDFN=$O(@ARRAY@(ECXADM,FHDFN)) Q:'FHDFN D 70 ..S ORDATE=0,(ADATE,DDATE,SDATE)="" 71 ..F S ORDATE=$O(@ARRAY@(ECXADM,FHDFN,ORDATE)) Q:'ORDATE D 72 ...S DATES=$$GETDATES() 73 ...N SONODE,NUM S (SONODE,ECXORDPH)="",NUM=0 74 ...S NUM=$O(@ARRAY@(ECXADM,FHDFN,ORDATE,"SO",NUM)) Q:'NUM D 75 ....S SONODE=$G(@ARRAY@(ECXADM,FHDFN,ORDATE,"SO",NUM)) 76 ....I +SONODE D 77 .....;create standing order meals 78 .....N SMEAL S P="INP",D="SO" 79 .....;get new order date and time if exist 80 .....S NORDER=$$NEWORDER(D,ORDATE),SMEAL=$P(SONODE,U,3) 81 .....S PRODUCT=$P(SONODE,U,2),ECXQTY=$P(SONODE,U,8) 82 .....;Resolve feeder key for nutrition product 83 .....S ECXKEY=$$NUTKEY^ECXUTL6(D,PRODUCT) 84 .....I $$NUTLOC^ECXUTL6(P,D,.ECXFPD,.ECXFDD,.ECXFPF,.ECXDLT,.ECXDFL) 85 .....;create individual meals 86 .....S MEAL=ORDATE F S MEAL=$O(MEALS(MEAL)) Q:'MEAL D 87 ......N TIME S TIME=$P(MEALS(MEAL),".",2) 88 ......Q:SMEAL'["B"&(TIME=08) 89 ......Q:SMEAL'["N"&(TIME=13) 90 ......Q:SMEAL'["E"&(TIME=18) 91 ......I $P(DATES,U) Q:MEAL>$P(DATES,U) 92 ......I NORDER]"" Q:MEAL>NORDER 93 ......I $P(DATES,U,3) Q:MEAL>$P(DATES,U,3) 94 ......;Get additional data and file record. 95 ......S DATE=MEAL D GET^ECXNUT 96 ;remove individual meals array 97 K MEALS 98 ;Get inpatient tube feedings 99 N P1,PNODE,CDATE,ECXTFU,MEALS 100 ;set daily meals array for inpatient tube feedings 101 F I=ECSD:1:ECED S MEALS(I)="" 102 S (FHDFN,DATE,P1,CDATE)=0,(ECXADM,NODE,ECXORDPH,PNODE)="" 103 S P="INP",D="TF" F S ECXADM=$O(^TMP($J,"FH",ECXADM)) Q:'ECXADM D 104 .F S FHDFN=$O(^TMP($J,"FH",ECXADM,FHDFN)) Q:'FHDFN D 105 ..F S DATE=$O(^TMP($J,"FH",ECXADM,FHDFN,DATE)) Q:'DATE D 106 ...S NODE=$G(^TMP($J,"FH",ECXADM,FHDFN,DATE,"TF")) Q:'NODE D 107 ....F S P1=$O(^TMP($J,"FH",ECXADM,FHDFN,DATE,"TF",P1)) Q:'P1 D 108 .....S PNODE=^TMP($J,"FH",ECXADM,FHDFN,DATE,"TF",P1,"P") 109 .....S ORDATE=DATE,DATES=$$GETDATES(),CDATE=$P(NODE,U,11) 110 .....S PRODUCT=$P(PNODE,U,1),ORDER=""_$P(NODE,U,14)_","_"" 111 .....S ECXQTY=$S($P(PNODE,U,3)["GM":$P(PNODE,U,3),1:$P(PNODE,U,4)) 112 .....S ECXTFU=$S($P(PNODE,U,3)["GM":"GM",1:"ML") 113 .....;Resolve external value for product key 114 .....S ECXKEY=$$NUTKEY^ECXUTL6(D,PRODUCT) 115 .....I $$NUTLOC^ECXUTL6(P,D,.ECXFPD,.ECXFDD,.ECXFPF,.ECXDLT,.ECXDFL) 116 .....;create daily meals 117 .....S MEAL=DATE F S MEAL=$O(MEALS(MEAL)) Q:'MEAL D 118 ......I $P(DATES,U) Q:MEAL>$P(DATES,U) 119 ......I CDATE]"" Q:MEAL>CDATE 120 ......I $P(DATES,U,3) Q:MEAL>$P(DATES,U,3) 121 ......S ECXORDPH=$$GET1^DIQ(100,ORDER,1,"I") 122 ......;Get additional data and file record. 123 ......S DATE=MEAL D GET^ECXNUT S DATE=ORDATE 124 ;Get outpatient recurring meals 125 S DATE=0,(ECXADM,NODE,ECXORDPH,ECXTFU)="" 126 S P="OP",D="RM" F S DATE=$O(^TMP($J,"FH",DATE)) Q:'DATE D 127 . S FHDFN=0 F S FHDFN=$O(^TMP($J,"FH",DATE,FHDFN)) Q:'FHDFN D 128 .. S NUMBER=0 F S NUMBER=$O(^TMP($J,"FH",DATE,FHDFN,NUMBER)) Q:'NUMBER D 129 ... S NODE=$G(^TMP($J,"FH",DATE,FHDFN,NUMBER,"RM")) Q:'NODE 130 ... S PRODUCT=$P(NODE,U,2),ECXQTY=1,ORDER=""_$P(NODE,U,12)_","_"" 131 ... S PRODUCT=$$GET1^DIQ(111,PRODUCT,4,"I") 132 ... S ECXORDPH=$$GET1^DIQ(100,ORDER,1,"I") 133 ... ;Resolve external value for product key 134 ... S ECXKEY=$$NUTKEY^ECXUTL6("PD",PRODUCT) 135 ... I $$NUTLOC^ECXUTL6(P,D,.ECXFPD,.ECXFDD,.ECXFPF,.ECXDLT,.ECXDFL) 136 ... ;Get additional data and file record. 137 ... D GET^ECXNUT 138 ;Get outpatient tube feedings 139 S DATE=0,(ECXADM,NODE,ECXORDPH)="" 140 S P="OP",D="TF" F S DATE=$O(^TMP($J,"FH",DATE)) Q:'DATE D 141 . S FHDFN=0 F S FHDFN=$O(^TMP($J,"FH",DATE,FHDFN)) Q:'FHDFN D 142 .. S NUMBER=0 F S NUMBER=$O(^TMP($J,"FH",DATE,FHDFN,NUMBER)) Q:'NUMBER D 143 ... S NODE=$G(^TMP($J,"FH",DATE,FHDFN,NUMBER,"RMTF")) Q:NODE="" 144 ... S TF=0 F S TF=$O(^TMP($J,"FH",DATE,FHDFN,NUMBER,"RMTF",TF)) Q:'TF D 145 .... S TFNODE=^TMP($J,"FH",DATE,FHDFN,NUMBER,"RMTF",TF) 146 .... S PRODUCT=$P(TFNODE,U,1),ECXQTY=$P(TFNODE,U,4) 147 .... ;Resolve external value for product key 148 .... S ECXKEY=$$NUTKEY^ECXUTL6("TF",PRODUCT) 149 .... I $$NUTLOC^ECXUTL6(P,D,.ECXFPD,.ECXFDD,.ECXFPF,.ECXDLT,.ECXDFL) 150 .... ;Get additional data and file record. 151 .... D GET^ECXNUT 152 ;Get outpatient special meals 153 S (FHDFN,DATE)=0,(ECXADM,NODE,ECXORDPH)="" 154 S P="OP",D="SM" F S DATE=$O(^TMP($J,"FH",DATE)) Q:'DATE D 155 . F S FHDFN=$O(^TMP($J,"FH",DATE,FHDFN)) Q:'FHDFN D 156 .. S NODE=$G(^TMP($J,"FH",DATE,FHDFN,"SM")) Q:'NODE 157 .. S PRODUCT=$P(NODE,U,4),ECXQTY=1,ECXORDPH=$P(NODE,U,5) 158 .. S PRODUCT=$$GET1^DIQ(111,PRODUCT,4,"I") 159 .. ;Resolve external value for product key 160 .. S ECXKEY=$$NUTKEY^ECXUTL6("SM",PRODUCT) 161 .. I $$NUTLOC^ECXUTL6(P,D,.ECXFPD,.ECXFDD,.ECXFPF,.ECXDLT,.ECXDFL) 162 .. ;Get additional data and file record. 163 .. D GET^ECXNUT 164 ;Get outpatient guest meals 165 S (FHDFN,DATE)=0,(ECXADM,NODE,ECXORDPH)="" 166 S P="OP",D="GM" F S DATE=$O(^TMP($J,"FH",DATE)) Q:'DATE D 167 . F S FHDFN=$O(^TMP($J,"FH",DATE,FHDFN)) Q:'FHDFN D 168 .. S NODE=$G(^TMP($J,"FH",DATE,FHDFN,"GM")) Q:'NODE 169 .. S PRODUCT=$P(NODE,U,13),ECXQTY=1 170 .. ;Resolve external value for product key 171 .. S ECXKEY=$$NUTKEY^ECXUTL6("GM",PRODUCT) 172 .. I $$NUTLOC^ECXUTL6(P,D,.ECXFPD,.ECXFDD,.ECXFPF,.ECXDLT,.ECXDFL) 173 .. ;Get additional data and file record. 174 .. D GET^ECXNUT 175 Q 176 GETDATES() ;Get admit, discharge, npo/withhold dates,for "inp", "sf" and "so" 177 ; return in string i.e. stop date^admission date^discharge date 178 ; input: ecxadm - movement file ien 179 ; fhdfn - nutrition patient file (#115) 180 ; 181 ; output: stop date - npo/withhold date 182 ; admit date - admission date and time 183 ; discharge date - discharge date and time 184 ;init variables 185 N ADATE,DDATE,DATE,STDATE,NORDATE,IENS 186 ;check input 187 Q:'$G(ECXADM)!'$G(FHDFN) "0^0^0" 188 ;get admission and discharge dates 189 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") 190 ;get "inp" order's npo/withhold date return it as 'stdate' if exist 191 S DATE=ORDATE F S DATE=$O(@ARRAY@(ECXADM,FHDFN,DATE)) Q:'DATE D 192 .I $P($G(@ARRAY@(ECXADM,FHDFN,+DATE,"INP")),U,7)'="" S STDATE=DATE 193 Q STDATE_U_ADATE_U_DDATE 194 NEWORDER(TYPE,DATE) ;Look for new order for inpatient meal type if exist 195 ; Input ecxadm - movement # 196 ; fhdfn - nutrition file (#115) fhdfn 197 ; date - starting order date to begin lookup 198 ; type - meal type "sf", "so", or "pd" 199 ; Output: new order date and time for specific meal type 200 ;init variables 201 N NORDER 202 S NORDER="" 203 ;check input 204 Q:$G(TYPE)']""!'$G(DATE) NORDER 205 F S DATE=$O(@ARRAY@(ECXADM,FHDFN,DATE)) Q:'DATE Q:NORDER D 206 .S NODE=$G(^TMP($J,"FH",ECXADM,FHDFN,DATE,TYPE)) Q:'NODE 207 .S NORDER=DATE 208 Q NORDER 1 ECXNUT1 ;ALB/JRC Nutrition DSS Extract ; 10/27/06 1:53pm 2 ;;3.0;DSS EXTRACTS;**92**;Dec 22, 1997;Build 30 3 Q 4 ; 5 GETMEALS ;get patient meals 6 ;init variables 7 N DATE,FHDFN,ECXADM,NODE,PRODUCT,ECXQTY,ORDER,ECXORDPH,ECXKEY,P,D 8 N ECXFPD,ECXFDD,ECXFPF,ECXDLT,ECXDFL,NUMBER,PNODE,SF,TF,TFNODE 9 ;S (DATE,FHDFN,NUMBER,ECXQTY)=0,(ECXADM,NODE,ORDER,ECXORDPH)="" 10 ;Get inpatient diets 11 ;S P="INP",D="PD" F S DATE=$O(^TMP($J,"FH",DATE)) Q:'DATE D 12 ;. F S FHDFN=$O(^TMP($J,"FH",DATE,FHDFN)) Q:'FHDFN D 13 ;.. F S ECXADM=$O(^TMP($J,"FH",DATE,FHDFN,ECXADM)) Q:'ECXADM D 14 ;... S NODE=$G(^TMP($J,"FH",DATE,FHDFN,ECXADM,"INP")) Q:'NODE 15 ;... S PRODUCT=$P(NODE,U,13),ECXQTY=1,ORDER=""_$P(NODE,U,14)_","_"" 16 ;... S ECXORDPH=$$GET1^DIQ(100,+ORDER,1,"I") 17 ;... ;Resolve feeder key for nutrition product 18 ;... S ECXKEY=$$NUTKEY^ECXUTL6("PD",PRODUCT) 19 ;... I $$NUTLOC^ECXUTL6(P,D,.ECXFPD,.ECXFDD,.ECXFPF,.ECXDLT,.ECXDFL) 20 ;... ;Get additional data and file record. 21 ;... D GET^ECXNUT 22 ;Get inpatient supplemental feedings 23 ;S (FHDFN,DATE)=0,(ECXADM,NODE,ORDER,ECXORDPH)="" 24 ;S P="INP",D="SF" F S DATE=$O(^TMP($J,"FH",DATE)) Q:'DATE D 25 ;. F S FHDFN=$O(^TMP($J,"FH",DATE,FHDFN)) Q:'FHDFN D 26 ;.. F S ECXADM=$O(^TMP($J,"FH",DATE,FHDFN,ECXADM)) Q:'ECXADM D 27 ;... S NODE=$G(^TMP($J,"FH",DATE,FHDFN,ECXADM,"SF")) Q:'NODE 28 ;... F SF=5:2:27 S PRODUCT=$P(NODE,U,SF) Q:PRODUCT']"" S ECXQTY=1 D 29 ;.... S ORDER=""_$P(NODE,U,7)_","_"" 30 ;.... S ECXORDPH=$$GET1^DIQ(100,ORDER,1,"I") 31 ;.... ;Resolve external value for product key 32 ;.... S ECXKEY=$$NUTKEY^ECXUTL6("SF",PRODUCT) 33 ;.... I $$NUTLOC^ECXUTL6(P,D,.ECXFPD,.ECXFDD,.ECXFPF,.ECXDLT,.ECXDFL) 34 ;.... ;Get additional data and file record. 35 ;.... D GET^ECXNUT 36 ;Get inpatient standing orders 37 ;S (FHDFN,DATE)=0,(ECXADM,NODE,ECXORDPH)="" 38 ;S P="INP",D="SO" F S DATE=$O(^TMP($J,"FH",DATE)) Q:'DATE D 39 ;. F S FHDFN=$O(^TMP($J,"FH",DATE,FHDFN)) Q:'FHDFN D 40 ;.. F S ECXADM=$O(^TMP($J,"FH",DATE,FHDFN,ECXADM)) Q:'ECXADM D 41 ;... S NODE=$G(^TMP($J,"FH",DATE,FHDFN,ECXADM,"SO")) Q:'NODE 42 ;... S PRODUCT=$P(NODE,U,2),ECXQTY=1 43 ;... ;Resolve external value for product key 44 ;... S ECXKEY=$$NUTKEY^ECXUTL6("SO",PRODUCT) 45 ;... I $$NUTLOC^ECXUTL6(P,D,.ECXFPD,.ECXFDD,.ECXFPF,.ECXDLT,.ECXDFL) 46 ;... ;Get additional data and file record. 47 ;... D GET^ECXNUT 48 ;Get inpatient tube feedings 49 ;S (FHDFN,DATE,P)=0,(ECXADM,NODE,ECXORDPH,PNODE)="" 50 ;S P="INP",D="TF" F S DATE=$O(^TMP($J,"FH",DATE)) Q:'DATE D 51 ;. F S FHDFN=$O(^TMP($J,"FH",DATE,FHDFN)) Q:'FHDFN D 52 ;.. F S ECXADM=$O(^TMP($J,"FH",DATE,FHDFN,ECXADM)) Q:'ECXADM D 53 ;... S NODE=$G(^TMP($J,"FH",DATE,FHDFN,ECXADM,"TF")) Q:'NODE 54 ;... S P=$O(^TMP($J,"FH",DATE,FHDFN,ECXADM,"TF",P)) Q:'P D 55 ;.... S PNODE=^TMP($J,"FH",DATE,FHDFN,ECXADM,"TF",P,"P") 56 ;.... S PRODUCT=$P(PNODE,U,1),ECXQTY=$P(PNODE,U,4) 57 ;.... S ORDER=""_$P(NODE,U,14)_","_"" 58 ;.... S ECXORDPH=$$GET1^DIQ(100,ORDER,1,"I") 59 ;.... ;Resolve external value for product key 60 ;.... S ECXKEY=$$NUTKEY^ECXUTL6("TF",PRODUCT) 61 ;.... I $$NUTLOC^ECXUTL6(P,D,.ECXFPD,.ECXFDD,.ECXFPF,.ECXDLT,.ECXDFL) 62 ;.... ;Get additional data and file record. 63 ;.... D GET^ECXNUT 64 ;Get outpatient recurring meals 65 S (FHDFN,DATE)=0,(ECXADM,NODE,ECXORDPH)="" 66 S P="OP",D="RM" F S DATE=$O(^TMP($J,"FH",DATE)) Q:'DATE D 67 . F S FHDFN=$O(^TMP($J,"FH",DATE,FHDFN)) Q:'FHDFN D 68 .. S NUMBER=0 F S NUMBER=$O(^TMP($J,"FH",DATE,FHDFN,NUMBER)) Q:'NUMBER D 69 ... S NODE=$G(^TMP($J,"FH",DATE,FHDFN,NUMBER,"RM")) Q:'NODE 70 ... S PRODUCT=$P(NODE,U,2),ECXQTY=1,ORDER=""_$P(NODE,U,12)_","_"" 71 ... S PRODUCT=$$GET1^DIQ(111,PRODUCT,4,"I") 72 ... S ECXORDPH=$$GET1^DIQ(100,ORDER,1,"I") 73 ... ;Resolve external value for product key 74 ... S ECXKEY=$$NUTKEY^ECXUTL6("PD",PRODUCT) 75 ... I $$NUTLOC^ECXUTL6(P,D,.ECXFPD,.ECXFDD,.ECXFPF,.ECXDLT,.ECXDFL) 76 ... ;Get additional data and file record. 77 ... D GET^ECXNUT 78 ;Get outpatient tube feedings 79 S (FHDFN,DATE,NUMBER)=0,(ECXADM,NODE,ECXORDPH)="" 80 S P="OP",D="TF" F S DATE=$O(^TMP($J,"FH",DATE)) Q:'DATE D 81 . F S FHDFN=$O(^TMP($J,"FH",DATE,FHDFN)) Q:'FHDFN D 82 .. F S NUMBER=$O(^TMP($J,"FH",DATE,FHDFN,NUMBER)) Q:'NUMBER D 83 ... S NODE=$G(^TMP($J,"FH",DATE,FHDFN,NUMBER,"RMTF")) Q:'NODE 84 ... S TF=$O(^TMP($J,"FH",DATE,FHDFN,NUMBER,"RMTF",TF)) Q:'TF D 85 .... S TFNODE=^TMP($J,"FH",DATE,FHDFN,NUMBER,"RMTF",TF) 86 .... S PRODUCT=$P(TFNODE,U,1),ECXQTY=$P(TFNODE,U,4) 87 .... ;Resolve external value for product key 88 .... S ECXKEY=$$NUTKEY^ECXUTL6("TF",PRODUCT) 89 .... I $$NUTLOC^ECXUTL6(P,D,.ECXFPD,.ECXFDD,.ECXFPF,.ECXDLT,.ECXDFL) 90 .... ;Get additional data and file record. 91 .... D GET^ECXNUT 92 ;Get outpatient special meals 93 S (FHDFN,DATE)=0,(ECXADM,NODE,ECXORDPH)="" 94 S P="OP",D="SM" F S DATE=$O(^TMP($J,"FH",DATE)) Q:'DATE D 95 . F S FHDFN=$O(^TMP($J,"FH",DATE,FHDFN)) Q:'FHDFN D 96 .. S NODE=$G(^TMP($J,"FH",DATE,FHDFN,"SM")) Q:'NODE 97 .. S PRODUCT=$P(NODE,U,13),ECXQTY=1,ECXORDPH=$P(NODE,U,5) 98 .. ;Resolve external value for product key 99 .. S ECXKEY=$$NUTKEY^ECXUTL6("SM",PRODUCT) 100 .. I $$NUTLOC^ECXUTL6(P,D,.ECXFPD,.ECXFDD,.ECXFPF,.ECXDLT,.ECXDFL) 101 .. ;Get additional data and file record. 102 .. D GET^ECXNUT 103 ;Get outpatient guest meals 104 S (FHDFN,DATE)=0,(ECXADM,NODE,ECXORDPH)="" 105 S P="OP",D="GM" F S DATE=$O(^TMP($J,"FH",DATE)) Q:'DATE D 106 . F S FHDFN=$O(^TMP($J,"FH",DATE,FHDFN)) Q:'FHDFN D 107 .. S NODE=$G(^TMP($J,"FH",DATE,FHDFN,"GM")) Q:'NODE 108 .. S PRODUCT=$P(NODE,U,13),ECXQTY=1 109 .. ;Resolve external value for product key 110 .. S ECXKEY=$$NUTKEY^ECXUTL6("GM",PRODUCT) 111 .. I $$NUTLOC^ECXUTL6(P,D,.ECXFPD,.ECXFDD,.ECXFPF,.ECXDLT,.ECXDFL) 112 .. ;Get additional data and file record. 113 .. D GET^ECXNUT 114 Q -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXOPRX.m
r613 r623 1 ECXOPRX ;ALB/JAP,BIR/DMA,CML,PTD-Prescription Extract for DSS ; 11/5/07 8:17am 2 ;;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 3 ; 4 BEG ;entry point from option 5 D SETUP I ECFILE="" Q 6 D ^ECXTRAC,^ECXKILL 7 Q 8 ; 9 START ;entry when queued 10 N X,DA,DIC,DIQ,DR,ECXNPRFI,ECRXPTST,ECNONVAP,ECRXNUM,ECXSCRX 11 S QFLG=0 12 I '$D(ECINST) D 13 .S ECINST=+$P(^ECX(728,1,0),U) K ECXDIC S DA=ECINST,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99" 14 .D EN^DIQ1 S ECINST=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC 15 ;before V6 16 S ECPROF=6,ECD=$O(^PSRX("AL",0)) I ECD,ECD<ECSD1 G V6 17 S ECED=ECED+.3,ECREF=1,ECD=ECSD1 18 F S ECD=$O(^PSRX("AD",ECD)),ECRX=0 Q:'ECD Q:ECD>ECED 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 19 Q 20 ; 21 V6 ;version 6 or better 22 K ^TMP($J,"ECXP") 23 S ECPROF=2,ECED=ECED+.3,ECREF=1,ECD=ECSD1 24 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 25 Q:QFLG 26 S ECREF="P",ECD=ECSD1 27 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 28 K ^TMP($J,"ECXP") 29 Q 30 ; 31 STUFF ;get data 32 N ECXPHA 33 S ECDATA=$G(^PSRX(ECRX,0)),ECXPHA="" 34 I ECRFL S ECDATA1=$G(^PSRX(ECRX,ECREF,ECRFL,0)) I ECDATA1="" Q 35 ;ecref set to 1 in extract+5 and v6+1 and to "P" in v6+2 36 ;refill nodes and partial nodes are identical in layout. Fills 37 ;(ie ecrfl=0)& refills (ie ecrfl>0) from "AL" xref, partials from "AM" 38 S (ECXDSSD,ECXPROVN,ECXCVE,ECXCVEDT,ECXCVENC,ECRXPTST,ECRXNUM)="",ECXERR=0,ECXDATE=ECD,ECXDFN=$P(ECDATA,U,2),ECDRG=+$P(ECDATA,U,6) 39 ;- Get rx patient status & rx number 40 S ECRXPTST=$$RXPTST^ECXUTL5($P(ECDATA,U,3)),ECRXNUM=$P(ECDATA,U,1) 41 ;- Get provider (either 2_provider or 6_provider depending on version) 42 S ECXPROV=$S($P(ECDATA,U,4)'="":ECPROF_$P(ECDATA,U,4),1:""),ECXPROVP=$$PRVCLASS^ECXUTL($P(ECDATA,U,4),ECXDATE) 43 S ECPRVNPI=$$NPI^XUSNPI("Individual_ID",$P(ECDATA,U,4),ECXDATE) 44 S:+ECPRVNPI'>0 ECPRVNPI="" S ECPRVNPI=$P(ECPRVNPI,U) 45 ;get classification data 46 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) 47 F X="ECXMIL","ECXAO","ECXIR","ECXECE","ECXHNC" S @X=$S(@X:"Y",@X=0:"N",1:"") 48 ;- Check non-va provider flag and set to 'Y' if exist 49 S ECNONVAP=$$NONVAP^ECXUTL5($E(ECXPROV,2,99)) 50 ;get patient specific data 51 D PAT(ECXDFN,ECXDATE,.ECXERR) Q:ECXERR 52 I 'ECRFL D 53 .S ECMW=$P(ECDATA,U,11),ECQTY=+$P(ECDATA,U,7),ECXDIV=$S($D(^PSRX(ECRX,2)):$P(^(2),U,9),1:1) 54 .S ECPRC=+$P(ECDATA,U,17),ECOPAY=$P($G(^PSRX(ECRX,"IB")),U,2)]"" 55 I ECRFL D 56 .S ECMW=$P(ECDATA1,U,2),ECQTY=+$P(ECDATA1,U,4),ECXDIV=$S(+$P(ECDATA1,U,9):$P(ECDATA1,U,9),1:1) 57 .S ECPRC=+$P(ECDATA1,U,11),ECOPAY=$P($G(^PSRX(ECRX,1,ECRFL,"IB")),U)]"" 58 S ECXCOST=$J((ECQTY*ECPRC),1,2),ECDS=$S(ECRFL:$P(ECDATA1,U,10),1:$P(ECDATA,U,8)) 59 ;call pharmacy drug file (#50) api 60 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) 61 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) 62 S X="PSNAPIS" X ^%ZOSF("TEST") I $T S ECNFC=$$DSS^PSNAPIS(P1,P3,ECXYM)_ECNFC 63 I $L(ECNFC)=12 S ECNFC=$$RJ^XLFSTR(P1,4,0)_$$RJ^XLFSTR(P3,3,0)_ECNFC 64 I ECMW="M" S ECMW=1 I $D(^PSRX("AR",ECD,ECRX)) S ECMW=2 65 I ECMW="W" S ECMW="" 66 S ECXNEW="" I ECRFL=0 S ECXNEW=1 67 S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS) ;Observation pat indic (YES/NO) 68 S ECXORDPH="" ;Ordering physician (null for FY2002) 69 ;- Ordering stop code & Ordering date 70 S ECXORDST=$P($G(^ECX(728.44,+$P(ECDATA,U,5),0)),U,2),ECXORDDT=$$ECXDATE^ECXUTL(+$P(ECDATA,U,13),ECXYM) 71 S ECXCNH=$$CNHSTAT^ECXUTL4(ECXDFN) ;CNH status (YES/NO) 72 ;- DSS Dept and National Prod Division 73 ;S ECXDSSD=$$PRE^ECXDEPT(ECXDIV,ECMW,ECINST) dss department postponed 74 N ECXPDIV S ECXPDIV=$$PREDIV^ECXDEPT(ECXDIV) 75 ;- Set national patient record flag if exist 76 D NPRF^ECXUTL5 77 S ECXSCRX=$$SCRX^ECXUTL5(ECRX) ;Service connected rx 78 ;- If no encounter number don't file record 79 S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,,) 80 I ECXLOGIC>2003 D 81 .I (ECMW=2)!((ECMW=1)&(ECXLOGIC>2006)),ECXSSN'="" D 82 ..N TMP S TMP=$$JULDT^ECXUTL4(ECD),ECXENC=$E(ECXSSN,1,9)_TMP_"160",ECXA="O" 83 I ECXENC'="" D FILE^ECXOPRX1 84 Q 85 ; 86 PAT(ECXDFN,ECXDATE,ECXERR) ;Determine in/outpatient status, movement number, primary care team and provider 87 N OK,X,PT 88 S (ECXCAT,ECXSTAT,ECXPRIOR,ECXSBGRP,ECXOEF,ECXOEFDT)="" 89 ;get patient data if saved 90 I $D(^TMP($J,"ECXP",ECXDFN)) D 91 .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) 92 .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) 93 .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) 94 .S ECXPHI=$P(PT,U,20),ECXCAT=$P(PT,U,21),ECXSTAT=$P(PT,U,22),ECXPRIOR=$P(PT,U,23) 95 .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) 96 .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) 97 .I $$ENROLLM^ECXUTL2(ECXDFN) 98 ;set patient data 99 I '$D(^TMP($J,"ECXP",ECXDFN)) D Q:'OK 100 .K ECXPAT 101 .S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECSD1,"."),"1;2;3;5",.ECXPAT) 102 .I 'OK S ECXERR=1 Q 103 .S ECXSSN=ECXPAT("SSN"),ECXPNM=ECXPAT("NAME"),ECXMPI=ECXPAT("MPI"),ECXSEX=ECXPAT("SEX"),ECXDOB=ECXPAT("DOB"),ECXELIG=ECXPAT("ELIG") 104 .S ECXVET=ECXPAT("VET"),ECXRACE=ECXPAT("RACE"),ECXPST=ECXPAT("POW STAT"),ECXPLOC=ECXPAT("POW LOC"),ECXRST=ECXPAT("IR STAT") 105 .S ECXAST=ECXPAT("AO STAT"),ECXMST=ECXPAT("MST STAT"),ECXSTATE=ECXPAT("STATE"),ECXCNTY=ECXPAT("COUNTY"),ECXZIP=ECXPAT("ZIP"),ECXENRL=ECXPAT("ENROLL LOC") 106 .S ECXERI=ECXPAT("ERI"),ECXEST=ECXPAT("EC STAT") 107 .;- CNH Stat (placeholder),Purp Heart Ind,Per of Svce,AO Loc,MT Stat 108 .S ECXCNHU="",ECXPHI=ECXPAT("PHI"),ECXPOS=ECXPAT("POS"),ECXAOL=ECXPAT("AOL"),ECXMTST=ECXPAT("MEANS") 109 .I $$ENROLLM^ECXUTL2(ECXDFN) 110 .S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) ;Head and Neck Cancer Indicator 111 .S ECXETH=ECXPAT("ETHNIC"),ECXRC1=ECXPAT("RACE1") ;Race and Ethnicity 112 .; OEF/OIF data 113 .S ECXOEF=ECXPAT("ECXOEF") 114 .S ECXOEFDT=ECXPAT("ECXOEFDT") 115 .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 116 .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 117 .S ^TMP($J,"ECXP",ECXDFN,1)=ECXERI_U_ECXEST_U_ECXOEF_U_ECXOEFDT 118 ;get inpatient data 119 S (ECXA,ECXADMDT,ECXDOM,ECXMN,ECXTS)="",X=$$INP^ECXUTL2(ECXDFN,ECXDATE) D 120 .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) 121 ;get primary care data 122 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) 123 Q 124 ; 125 SETUP ;Set required input for ECXTRAC 126 S ECHEAD="PRE" 127 D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) 128 Q 129 QUE ; entry point for the background requeuing handled by ECXTAUTO 130 D SETUP,QUE^ECXTAUTO,^ECXKILL Q 1 ECXOPRX ;ALB/JAP,BIR/DMA,CML,PTD-Prescription Extract for DSS ; 11/2/06 8:42am 2 ;;3.0;DSS EXTRACTS;**10,11,8,13,24,30,33,38,39,46,49,71,81,84,92**;Dec 22, 1997;Build 30 3 ; 4 BEG ;entry point from option 5 D SETUP I ECFILE="" Q 6 D ^ECXTRAC,^ECXKILL 7 Q 8 ; 9 START ;entry when queued 10 N X,DA,DIC,DIQ,DR,ECXNPRFI,ECRXPTST,ECNONVAP,ECRXNUM,ECXSCRX 11 S QFLG=0 12 I '$D(ECINST) D 13 .S ECINST=+$P(^ECX(728,1,0),U) K ECXDIC S DA=ECINST,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99" 14 .D EN^DIQ1 S ECINST=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC 15 ;before V6 16 S ECPROF=6,ECD=$O(^PSRX("AL",0)) I ECD,ECD<ECSD1 G V6 17 S ECED=ECED+.3,ECREF=1,ECD=ECSD1 18 F S ECD=$O(^PSRX("AD",ECD)),ECRX=0 Q:'ECD Q:ECD>ECED 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 19 Q 20 ; 21 V6 ;version 6 or better 22 K ^TMP($J,"ECXP") 23 S ECPROF=2,ECED=ECED+.3,ECREF=1,ECD=ECSD1 24 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 25 Q:QFLG 26 S ECREF="P",ECD=ECSD1 27 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 28 K ^TMP($J,"ECXP") 29 Q 30 ; 31 STUFF ;get data 32 N ECXPHA 33 S ECDATA=$G(^PSRX(ECRX,0)),ECXPHA="" 34 I ECRFL S ECDATA1=$G(^PSRX(ECRX,ECREF,ECRFL,0)) I ECDATA1="" Q 35 ;ecref set to 1 in extract+5 and v6+1 and to "P" in v6+2 36 ;refill nodes and partial nodes are identical in layout. Fills 37 ;(ie ecrfl=0)& refills (ie ecrfl>0) from "AL" xref, partials from "AM" 38 S (ECXDSSD,ECXPROVN,ECXCVE,ECXCVEDT,ECXCVENC,ECRXPTST,ECRXNUM)="",ECXERR=0,ECXDATE=ECD,ECXDFN=$P(ECDATA,U,2),ECDRG=+$P(ECDATA,U,6) 39 ;- Get rx patient status & rx number 40 S ECRXPTST=$$RXPTST^ECXUTL5($P(ECDATA,U,3)),ECRXNUM=$P(ECDATA,U,1) 41 ;- Get provider (either 2_provider or 6_provider depending on version) 42 S ECXPROV=$S($P(ECDATA,U,4)'="":ECPROF_$P(ECDATA,U,4),1:""),ECXPROVP=$$PRVCLASS^ECXUTL($P(ECDATA,U,4),ECXDATE) 43 ;get classification data 44 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) 45 F X="ECXMIL","ECXAO","ECXIR","ECXECE","ECXHNC" S @X=$S(@X:"Y",@X=0:"N",1:"") 46 ;- Check non-va provider flag and set to 'Y' if exist 47 S ECNONVAP=$$NONVAP^ECXUTL5($E(ECXPROV,2,99)) 48 ;get patient specific data 49 D PAT(ECXDFN,ECXDATE,.ECXERR) Q:ECXERR 50 I 'ECRFL D 51 .S ECMW=$P(ECDATA,U,11),ECQTY=+$P(ECDATA,U,7),ECXDIV=$S($D(^PSRX(ECRX,2)):$P(^(2),U,9),1:1) 52 .S ECPRC=+$P(ECDATA,U,17),ECOPAY=$P($G(^PSRX(ECRX,"IB")),U,2)]"" 53 I ECRFL D 54 .S ECMW=$P(ECDATA1,U,2),ECQTY=+$P(ECDATA1,U,4),ECXDIV=$S(+$P(ECDATA1,U,9):$P(ECDATA1,U,9),1:1) 55 .S ECPRC=+$P(ECDATA1,U,11),ECOPAY=$P($G(^PSRX(ECRX,1,ECRFL,"IB")),U)]"" 56 S ECXCOST=$J((ECQTY*ECPRC),1,2),ECDS=$S(ECRFL:$P(ECDATA1,U,10),1:$P(ECDATA,U,8)) 57 ;call pharmacy drug file (#50) api 58 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) 59 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) 60 S X="PSNAPIS" X ^%ZOSF("TEST") I $T S ECNFC=$$DSS^PSNAPIS(P1,P3,ECXYM)_ECNFC 61 I $L(ECNFC)=12 S ECNFC=$$RJ^XLFSTR(P1,4,0)_$$RJ^XLFSTR(P3,3,0)_ECNFC 62 I ECMW="M" S ECMW=1 I $D(^PSRX("AR",ECD,ECRX)) S ECMW=2 63 I ECMW="W" S ECMW="" 64 S ECXNEW="" I ECRFL=0 S ECXNEW=1 65 S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS) ;Observation pat indic (YES/NO) 66 S ECXORDPH="" ;Ordering physician (null for FY2002) 67 ;- Ordering stop code & Ordering date 68 S ECXORDST=$P($G(^ECX(728.44,+$P(ECDATA,U,5),0)),U,2),ECXORDDT=$$ECXDATE^ECXUTL(+$P(ECDATA,U,13),ECXYM) 69 S ECXCNH=$$CNHSTAT^ECXUTL4(ECXDFN) ;CNH status (YES/NO) 70 ;- DSS Dept and National Prod Division 71 ;S ECXDSSD=$$PRE^ECXDEPT(ECXDIV,ECMW,ECINST) dss department postponed 72 N ECXPDIV S ECXPDIV=$$PREDIV^ECXDEPT(ECXDIV) 73 ;- Set national patient record flag if exist 74 D NPRF^ECXUTL5 75 S ECXSCRX=$$SCRX^ECXUTL5(ECRX) ;Service connected rx 76 ;- If no encounter number don't file record 77 S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,,) 78 I ECXLOGIC>2003 D 79 .I (ECMW=2)!((ECMW=1)&(ECXLOGIC>2006)),ECXSSN'="" D 80 ..N TMP S TMP=$$JULDT^ECXUTL4(ECD),ECXENC=$E(ECXSSN,1,9)_TMP_"160",ECXA="O" 81 I ECXENC'="" D FILE^ECXOPRX1 82 Q 83 ; 84 PAT(ECXDFN,ECXDATE,ECXERR) ;Determine in/outpatient status, movement number, primary care team and provider 85 N OK,X,PT 86 S (ECXCAT,ECXSTAT,ECXPRIOR,ECXSBGRP)="" 87 ;get patient data if saved 88 I $D(^TMP($J,"ECXP",ECXDFN)) D 89 .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) 90 .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) 91 .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) 92 .S ECXPHI=$P(PT,U,20),ECXCAT=$P(PT,U,21),ECXSTAT=$P(PT,U,22),ECXPRIOR=$P(PT,U,23) 93 .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) 94 .S PT1=$G(^TMP($J,"ECXP",ECXDFN,1)),ECXERI=$P(PT1,U),ECXEST=$P(PT1,U,2) 95 .I $$ENROLLM^ECXUTL2(ECXDFN) 96 ;set patient data 97 I '$D(^TMP($J,"ECXP",ECXDFN)) D Q:'OK 98 .K ECXPAT 99 .S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECSD1,"."),"1;2;3;5",.ECXPAT) 100 .I 'OK S ECXERR=1 Q 101 .S ECXSSN=ECXPAT("SSN"),ECXPNM=ECXPAT("NAME"),ECXMPI=ECXPAT("MPI"),ECXSEX=ECXPAT("SEX"),ECXDOB=ECXPAT("DOB"),ECXELIG=ECXPAT("ELIG") 102 .S ECXVET=ECXPAT("VET"),ECXRACE=ECXPAT("RACE"),ECXPST=ECXPAT("POW STAT"),ECXPLOC=ECXPAT("POW LOC"),ECXRST=ECXPAT("IR STAT") 103 .S ECXAST=ECXPAT("AO STAT"),ECXMST=ECXPAT("MST STAT"),ECXSTATE=ECXPAT("STATE"),ECXCNTY=ECXPAT("COUNTY"),ECXZIP=ECXPAT("ZIP"),ECXENRL=ECXPAT("ENROLL LOC") 104 .S ECXERI=ECXPAT("ERI"),ECXEST=ECXPAT("EC STAT") 105 .;- CNH Stat (placeholder),Purp Heart Ind,Per of Svce,AO Loc,MT Stat 106 .S ECXCNHU="",ECXPHI=ECXPAT("PHI"),ECXPOS=ECXPAT("POS"),ECXAOL=ECXPAT("AOL"),ECXMTST=ECXPAT("MEANS") 107 .I $$ENROLLM^ECXUTL2(ECXDFN) 108 .S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) ;Head and Neck Cancer Indicator 109 .S ECXETH=ECXPAT("ETHNIC"),ECXRC1=ECXPAT("RACE1") ;Race and Ethnicity 110 .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 111 .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 112 .S ^TMP($J,"ECXP",ECXDFN,1)=ECXERI_U_ECXEST 113 ;get inpatient data 114 S (ECXA,ECXADMDT,ECXDOM,ECXMN,ECXTS)="",X=$$INP^ECXUTL2(ECXDFN,ECXDATE) D 115 .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) 116 ;get primary care data 117 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) 118 Q 119 ; 120 SETUP ;Set required input for ECXTRAC 121 S ECHEAD="PRE" 122 D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) 123 Q 124 QUE ; entry point for the background requeuing handled by ECXTAUTO 125 D SETUP,QUE^ECXTAUTO,^ECXKILL Q -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXOPRX1.m
r613 r623 1 ECXOPRX1 ;ALB/JAP,BIR/DMA,CML,PTD-Prescription Extract for DSS ; 6/6/07 7:23am 2 ;;3.0;DSS EXTRACTS;**92,107,105**;Dec 22, 1997;Build 70 3 ; 4 FILE ;file record 5 ;node0 6 ;inst^dfn^ssn^name^in/out ECXA^day^division^provider^drug category^mail^ 7 ;placeholder1^new^placeholder2^qty^cost^placeholder3^mov #^treat spec^placeholder4^unit of issue^dob^elig^vet^copay^ 8 ;feeder key^investigational^days supply^primary care team^primary care provider^time^race 9 ;node1 10 ;mpi^dss dept ECXDSSD^sex^zip+4^placeholder^placeholder^state^county^pc prov person class^pow status^pow location^ 11 ;ir status^ao status^sharing agree. payor^sharing agree. ins.^mst status^enroll loc^assoc pc provider^assoc pc prov person class^ 12 ;placeholder^dom ECXDOM^purple heart ECXPHI^enrollment category ECXCAT^enrollment status ECXSTST^ 13 ;enrollment priority ECXPRIOR^cnhu status ECXCNHU^period of service ECXPOS^observ pat ind ECXOBS^encounter num ECXENC^ 14 ;ao loc ECXAOL^ord physician ECXORDPH^ord stop code ECXORDST^ord date ECXORDDT^CNH status ECXCNH^national division ECXPDIV^ 15 ;MT Stat ECXMTST^head & neck cancer ind. ECXHNCI^ethnicity ECXETH^race ECXRC1^^enrollment priority ECXPRIOR_ 16 ;enrollment subgroup ECXSBGRP^user enrollee ECXUESTA^patient type ECXPTYPE^combat vet elig ECXCVE^combat vet elig end date ECXCVEDT^ 17 ;enc cv eligible ECXCVENC^national patient record flag ECXNPRFI^rx patient status ECRXPTST^non-va prescriber ECNONVAP^rx # ECRXNUM 18 ;^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 19 ;OEF/OIF data ECXOEF^OEFOIF return date ECXOEFDT^associate pc provider npi ECASNPI^primary care provider npi ECPTNPI^provider npi ECPRVNPI 20 N DA,DIK 21 S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 22 S ECODE=EC7_U_EC23_U_ECINST_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U 23 S ECODE=ECODE_$$ECXDATE^ECXUTL(ECXDATE,ECXYM)_U_ECXDIV_U 24 S ECODE=ECODE_ECXPROV_U_ECCAT_U_ECMW_U_ECXPROVP_U_ECXNEW_U_U_ECQTY_U 25 ;convert specialty to PTF Code for transmission 26 N ECXDATA 27 S ECXDATA=$$TSDATA^DGACT(42.4,+ECXTS,.ECXDATA) 28 S ECXTS=$G(ECXDATA(7)) 29 ;done 30 S ECODE=ECODE_ECXCOST_U_U_ECXMN_U_ECXTS_U_U_ECUI_U_ECXDOB_U 31 S ECODE=ECODE_ECXELIG_U_ECXVET_U_ECOPAY_U_ECNFC_U_ECINV_U_ECDS_U 32 S ECODE=ECODE_ECPTTM_U_ECPTPR_U_$$ECXTIME^ECXUTL(ECXDATE)_U_ECXRACE_U 33 S ECODE1=ECXMPI_U_ECXDSSD_U_ECXSEX_U_ECXZIP_U_ECXPROVN_U_U 34 S ECODE1=ECODE1_ECXSTATE_U_ECXCNTY_U_ECCLAS_U_ECXPST_U_ECXPLOC_U 35 S ECODE1=ECODE1_ECXRST_U_ECXAST_U_U_U_ECXMST_U_ECXENRL_U 36 S ECODE1=ECODE1_ECASPR_U_ECCLAS2_U_U_ECXDOM_U_ECXPHI_U_ECXCAT_U 37 S ECODE1=ECODE1_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXCNHU_U_ECXPOS_U_ECXOBS_U 38 S ECODE1=ECODE1_ECXENC_U_ECXAOL_U_ECXORDPH_U_ECXORDST_U_ECXORDDT_U 39 S ECODE1=ECODE1_ECXCNH_U_ECXPDIV_U_ECXMTST_U_ECXHNCI_U_ECXETH_U 40 S ECODE1=ECODE1_ECXRC1_U 41 I ECXLOGIC>2004 S ECODE1=ECODE1_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U 42 I ECXLOGIC>2004 S ECODE2=ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXNPRFI_U_ECRXPTST_U_ECNONVAP 43 I ECXLOGIC>2005 S ECODE2=ECODE2_U_ECRXNUM 44 I ECXLOGIC>2006 S ECODE2=ECODE2_U_ECXERI_U_ECXAO_U_ECXECE_U_ECXHNC_U_ECXMIL_U_ECXEST_U_ECXIR_U_ECXSCRX 45 I ECXLOGIC>2007 S ECODE2=ECODE2_U_ECXOEF_U_ECXOEFDT_U_ECASNPI_U_ECPTNPI_U_ECPRVNPI 46 S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,^ECX(ECFILE,EC7,2)=$G(ECODE2),ECRN=ECRN+1 47 S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA 48 I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 49 Q 1 ECXOPRX1 ;ALB/JAP,BIR/DMA,CML,PTD-Prescription Extract for DSS ; 4/19/2007 2 ;;3.0;DSS EXTRACTS;**92,107**;Dec 22, 1997;Build 9 3 ; 4 FILE ;file record 5 ;node0 6 ;inst^dfn^ssn^name^in/out ECXA^day^division^provider^drug category^mail^ 7 ;placeholder1^new^placeholder2^qty^cost^placeholder3^mov #^treat spec^placeholder4^unit of issue^dob^elig^vet^copay^ 8 ;feeder key^investigational^days supply^primary care team^primary care provider^time^race 9 ;node1 10 ;mpi^dss dept ECXDSSD^sex^zip+4^provider npi^pc provider npi^state^county^pc prov person class^pow status^pow location^ 11 ;ir status^ao status^sharing agree. payor^sharing agree. ins.^mst status^enroll loc^assoc pc provider^assoc pc prov person class^ 12 ;assoc pc prov npi^dom ECXDOM^purple heart ECXPHI^enrollment category ECXCAT^enrollment status ECXSTST^ 13 ;enrollment priority ECXPRIOR^cnhu status ECXCNHU^period of service ECXPOS^observ pat ind ECXOBS^encounter num ECXENC^ 14 ;ao loc ECXAOL^ord physician ECXORDPH^ord stop code ECXORDST^ord date ECXORDDT^CNH status ECXCNH^national division ECXPDIV^ 15 ;MT Stat ECXMTST^head & neck cancer ind. ECXHNCI^ethnicity ECXETH^race ECXRC1^^enrollment priority ECXPRIOR_ 16 ;enrollment subgroup ECXSBGRP^user enrollee ECXUESTA^patient type ECXPTYPE^combat vet elig ECXCVE^combat vet elig end date ECXCVEDT^ 17 ;enc cv eligible ECXCVENC^national patient record flag ECXNPRFI^rx patient status ECRXPTST^non-va prescriber ECNONVAP^rx # ECRXNUM 18 ;^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 19 N DA,DIK 20 S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 21 S ECODE=EC7_U_EC23_U_ECINST_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U 22 S ECODE=ECODE_$$ECXDATE^ECXUTL(ECXDATE,ECXYM)_U_ECXDIV_U 23 S ECODE=ECODE_ECXPROV_U_ECCAT_U_ECMW_U_ECXPROVP_U_ECXNEW_U_U_ECQTY_U 24 ;convert specialty to PTF Code for transmission 25 N ECXDATA 26 S ECXDATA=$$TSDATA^DGACT(42.4,+ECXTS,.ECXDATA) 27 S ECXTS=$G(ECXDATA(7)) 28 ;done 29 S ECODE=ECODE_ECXCOST_U_U_ECXMN_U_ECXTS_U_U_ECUI_U_ECXDOB_U 30 S ECODE=ECODE_ECXELIG_U_ECXVET_U_ECOPAY_U_ECNFC_U_ECINV_U_ECDS_U 31 S ECODE=ECODE_ECPTTM_U_ECPTPR_U_$$ECXTIME^ECXUTL(ECXDATE)_U_ECXRACE_U 32 S ECODE1=ECXMPI_U_ECXDSSD_U_ECXSEX_U_ECXZIP_U_ECXPROVN_U_ECPTNPI_U 33 S ECODE1=ECODE1_ECXSTATE_U_ECXCNTY_U_ECCLAS_U_ECXPST_U_ECXPLOC_U 34 S ECODE1=ECODE1_ECXRST_U_ECXAST_U_U_U_ECXMST_U_ECXENRL_U 35 S ECODE1=ECODE1_ECASPR_U_ECCLAS2_U_ECASNPI_U_ECXDOM_U_ECXPHI_U_ECXCAT_U 36 S ECODE1=ECODE1_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXCNHU_U_ECXPOS_U_ECXOBS_U 37 S ECODE1=ECODE1_ECXENC_U_ECXAOL_U_ECXORDPH_U_ECXORDST_U_ECXORDDT_U 38 S ECODE1=ECODE1_ECXCNH_U_ECXPDIV_U_ECXMTST_U_ECXHNCI_U_ECXETH_U 39 S ECODE1=ECODE1_ECXRC1_U 40 I ECXLOGIC>2004 S ECODE1=ECODE1_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U 41 I ECXLOGIC>2004 S ECODE2=ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXNPRFI_U_ECRXPTST_U_ECNONVAP 42 I ECXLOGIC>2005 S ECODE2=ECODE2_U_ECRXNUM 43 I ECXLOGIC>2006 S ECODE2=ECODE2_U_ECXERI_U_ECXAO_U_ECXECE_U_ECXHNC_U_ECXMIL_U_ECXEST_U_ECXIR_U_ECXSCRX 44 S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,^ECX(ECFILE,EC7,2)=$G(ECODE2),ECRN=ECRN+1 45 S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA 46 I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 47 Q -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXPIVDN.m
r613 r623 1 ECXPIVDN ;ALB/JAP,BIR/DMA,CML,PTD-Extract from IV EXTRACT DATA File (#728.113) ; 10/31/07 1:38pm 2 ;;3.0;DSS EXTRACTS;**10,11,8,13,24,33,39,46,49,71,84,96,92,107,105**;Dec 22, 1997;Build 70 3 BEG ;entry point from option 4 D SETUP I ECFILE="" Q 5 D ^ECXTRAC,^ECXKILL 6 Q 7 ; 8 START ; start package specific extract 9 N DIC,DA,DR,DIQ,DFN,ECXNPRFI,ECXPHA 10 S QFLG=0 11 I '$D(ECINST) D 12 .S ECINST=+$P(^ECX(728,1,0),U) K ECXDIC S DA=ECINST,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99" 13 .D EN^DIQ1 S ECINST=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC 14 S ECED=ECED+.3 15 K ^TMP($J,"A"),^TMP($J,"S") 16 S ECD=ECSD1 17 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 18 .S ECXERR=0 D PAT(DFN,ECD,.ECXERR) 19 .Q:ECXERR 20 .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 21 ..S DRG=$P(EC,U,4) I $P(EC,U,8)]"" D 22 ...I '$D(^TMP($J,"A",DRG)) S ^(DRG)=$P(EC,U,7,8),^(DRG,1)=0,^(2)=$P(EC,U,12) 23 ...S ^(1)=^TMP($J,"A",DRG,1)+$S($P(EC,U,6)=1:1,$P(EC,U,6)=4:0,1:-1) 24 ..I $P(EC,U,9) D 25 ...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 26 ...S ^(1)=^TMP($J,"S",DRG,1)+$S($P(EC,U,6)=1:1,$P(EC,U,6)=4:0,1:-1) 27 ..S ECTYP=$P(EC,U,11),ECTOTC=0,ECDTTM=$$ECXTIME^ECXUTL($P(EC,U,5)) 28 .;looped thru all DAs for this order - now put it together 29 .;leave the next line in case the decision is made to send volume designations 30 .;I ECTYP="H" S ECTYP=ECTYP_$S(ECVOL'>1000:1,ECVOL'>2000:2,1:3) 31 .S ECXDSSI="" 32 .;loop thru tmp global and call pharmacy drug file (#50) api 33 .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 34 K ^TMP($J),CLIN,DA,DFN,DIC,DIK,DRG,ON,SA,X,Y,P1,P3 35 Q 36 STUFF ;get data 37 N ECORDST 38 S ECST=^TMP($J,SA,DRG),ECXCNT=^(DRG,1),ECXCOST=^(2),ECXCOST=ECXCOST*ECXCNT,ECVACL=$P(ECXPHA,U,2),ECORDST="" 39 ;if outpatient get division from iv rm; get dss identifier for clinic 40 I ECXA="O" D 41 .;- Only set ward to .5 if outpatient (but NOT observation patient) 42 .I $G(ECXW)="" S ECXW=.5 43 .I $P(EC,U,15) S ECIVRM=$P(EC,U,15),ECXDIV=$$PSJ59P5^ECXUTL5(ECIVRM) 44 .S CLIN=+$P(EC,U,13),(ECXP1,ECXP2)="000",ECXCL=$G(^ECX(728.44,CLIN,0)) Q:ECXCL="" 45 .S ECSC=$P(ECXCL,U,4),ECCSC=$P(ECXCL,U,5) 46 .I ECSC="" S ECSC=$P(ECXCL,U,2),ECCSC=$P(ECXCL,U,3) 47 .I ECSC S ECXP1=$$RJ^XLFSTR(ECSC,3,0),ECXP2=$$RJ^XLFSTR(ECCSC,3,0) 48 .I ECSC="" S ECSC=$P($G(^SC(ECXCL,0)),U,7),ECCSC=$P($G(^SC(ECXCL,0)),U,18) I ECSC D 49 ..S ECXP1=$P($G(^DIC(40.7,ECSC,0)),U,2) S:ECCSC]"" ECXP2=$P($G(^DIC(40.7,ECCSC,0)),U,2) 50 ..S ECXP1=$$RJ^XLFSTR(ECXP1,3,0),ECXP2=$$RJ^XLFSTR(ECXP2,3,0) 51 .S ECXDSSI=ECXP1_ECXP2 52 .I ECXLOGIC>2003 D 53 ..I "^18^23^24^36^41^65^94^"[("^"_ECXTS_"^") S ECXDSSI=$$TSMAP^ECXUTL4(ECXTS) 54 S ECINV=$P(ECXPHA,U,4),ECINV=$S(ECINV["I":"I",1:""),ECST=ECXCNT*ECST_" "_$P(ECST,U,2) 55 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) 56 S P1=$P(ECXPHA,U,5),P3=$P(ECXPHA,U,6) 57 S X="PSNAPIS" X ^%ZOSF("TEST") I $T S ECNFC=$$DSS^PSNAPIS(P1,P3,ECXYM)_ECNFC 58 I $L(ECNFC)=12 S ECNFC=$$RJ^XLFSTR(P1,4,0)_$$RJ^XLFSTR(P3,3,0)_ECNFC 59 ;- Ordering provider ("2"_provider) 60 S ECXORDPR=$S(+$P(EC,U,10):"2"_$P(EC,U,10),1:"") 61 N ECXUSRTN 62 S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",$P(EC,U,10),$P(EC,U,16)) 63 S:+ECXUSRTN'>0 ECXUSRTN="" S ECXOPNPI=$P(ECXUSRTN,U) 64 S ECXORDDT=$P(EC,U,16) ;- Ordering date 65 ;- Requesting physician (null for FY2002) 66 S ECXRPHY="" 67 ;- Department and National Prod Division 68 S ECXDSSD="" ;dss department use postponed $$IVP^ECXDEPT(ECXDIV) 69 N ECXPDIV S ECXPDIV=$$GETDIV^ECXDEPT(ECXDIV) 70 ;- Observation patient indicator (yes/no) 71 S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXDSSI) 72 ; - Ordering Date, Ordering Stop Code 73 S ECXORDST="" I ECXA="O" D 74 .S ECXORDST=$$DOIVPO^ECXUTL5(DFN,ON) 75 .I ECXOBS="NO" S ECORDST="160" 76 .I ECXOBS="YES" S ECORDST=$P($G(^ECX(727.831,+ECXTS,0)),U,6) 77 ;- If no encounter number don't file record 78 S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADM,ECD,ECXTS,ECXOBS,ECHEAD,ECORDST,) 79 ;get BCMA data 80 S (ECXBCDD,ECXBCDG,ECXBCUA,ECXBCIF)="" 81 ;get ordering provider person class 82 S ECXOPPC=$$PRVCLASS^ECXUTL($E(ECXORDPR,2,999),ECXORDDT) 83 ;set national patient record flag if exist 84 S ECXDFN=DFN D NPRF^ECXUTL5 K ECXDFN 85 D:ECXENC'="" FILE^ECXPIVD2 K P1,P3 86 Q 87 PAT(ECXDFN,ECXDATE,ECXERR) ;get patient demographics, primary care, and inpatient data 88 N X 89 S (ECXCAT,ECXSTAT,ECXPRIOR,ECXSBGRP,ECXOEF,ECXOEFDT)="" 90 ;get patient data if saved 91 I $D(^TMP($J,"ECXP",ECXDFN)) D 92 .S PT=^TMP($J,"ECXP",ECXDFN),ECXPNM=$P(PT,U),ECXSSN=$P(PT,U,2),ECXMPI=$P(PT,U,3) 93 .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) 94 .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) 95 .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) 96 .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) 97 .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) 98 .I $$ENROLLM^ECXUTL2(ECXDFN) 99 ;set patient data 100 I '$D(^TMP($J,"ECXP",ECXDFN)) D Q:'OK 101 .K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECXDATE,"."),"1;2;3;5",.ECXPAT) 102 .I 'OK K ECXPAT S ECXERR=1 Q 103 .S ECXPNM=ECXPAT("NAME"),ECXSSN=ECXPAT("SSN"),ECXMPI=ECXPAT("MPI"),ECXDOB=ECXPAT("DOB"),ECXELIG=ECXPAT("ELIG"),ECXSEX=ECXPAT("SEX") 104 .S ECXSTATE=ECXPAT("STATE"),ECXCNTY=ECXPAT("COUNTY"),ECXZIP=ECXPAT("ZIP"),ECXVET=ECXPAT("VET") 105 .S ECXPOS=ECXPAT("POS"),ECXPST=ECXPAT("POW STAT"),ECXPLOC=ECXPAT("POW LOC"),ECXRST=ECXPAT("IR STAT") 106 .S ECXAST=ECXPAT("AO STAT"),ECXAOL=ECXPAT("AOL"),ECXPHI=ECXPAT("PHI"),ECXMST=ECXPAT("MST STAT") 107 .S ECXENRL=ECXPAT("ENROLL LOC"),ECXMTST=ECXPAT("MEANS"),ECXEST=ECXPAT("EC STAT") 108 .S ECXCNHU=$$CNHSTAT^ECXUTL4(ECXDFN) ;get CNHU status 109 .;get enrollment data (category, status and priority) 110 .I $$ENROLLM^ECXUTL2(ECXDFN) 111 .S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) ;Head and Neck Cancer Indicator 112 .; - Race and Ethnicity 113 .S ECXETH=ECXPAT("ETHNIC"),ECXRC1=ECXPAT("RACE1") 114 .S ECXERI=ECXPAT("ERI") ;emergency response indicator (FEMA) 115 .S ECXOEF=ECXPAT("ECXOEF") 116 .S ECXOEFDT=ECXPAT("ECXOEFDT") 117 .;save for later 118 .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 119 .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 120 .S ^TMP($J,"ECXP",ECXDFN,1)=ECXERI_U_ECXEST_U_ECXOEF_U_ECXOEFDT 121 ;get primary care data 122 S X=$$PRIMARY^ECXUTL2(ECXDFN,$P(ECXDATE,".")) 123 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) 124 ;get inpatient data 125 S (ECXA,ECXMN,ECXADM,ECXTS,ECXW,ECXDIV)="",X=$$INP^ECXUTL2(ECXDFN,ECXDATE) 126 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) 127 Q 128 SETUP ;Set required input for ECXTRAC 129 S ECHEAD="IVP" 130 D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) 131 ;variables ecver and ecrtn will be reset in routine ecxtrac if appropriate 132 S ECVER=7 133 Q 134 QUE ; entry point for the background requeuing handled by ECXTAUTO 135 D SETUP,QUE^ECXTAUTO,^ECXKILL Q 1 ECXPIVDN ;ALB/JAP,BIR/DMA,CML,PTD-Extract from IV EXTRACT DATA File (#728.113) ; 4/19/2007 2 ;;3.0;DSS EXTRACTS;**10,11,8,13,24,33,39,46,49,71,84,96,92,107**;Dec 22, 1997;Build 9 3 START ; start package specific extract 4 N DIC,DA,DR,DIQ,DFN,ECXNPRFI,ECXPHA 5 S QFLG=0 6 I '$D(ECINST) D 7 .S ECINST=+$P(^ECX(728,1,0),U) K ECXDIC S DA=ECINST,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99" 8 .D EN^DIQ1 S ECINST=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC 9 S ECED=ECED+.3 10 K ^TMP($J,"A"),^TMP($J,"S") 11 S ECD=ECSD1 12 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 13 .S ECXERR=0 D PAT(DFN,ECD,.ECXERR) 14 .Q:ECXERR 15 .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 16 ..S DRG=$P(EC,U,4) I $P(EC,U,8)]"" D 17 ...I '$D(^TMP($J,"A",DRG)) S ^(DRG)=$P(EC,U,7,8),^(DRG,1)=0,^(2)=$P(EC,U,12) 18 ...S ^(1)=^TMP($J,"A",DRG,1)+$S($P(EC,U,6)=1:1,$P(EC,U,6)=4:0,1:-1) 19 ..I $P(EC,U,9) D 20 ...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 21 ...S ^(1)=^TMP($J,"S",DRG,1)+$S($P(EC,U,6)=1:1,$P(EC,U,6)=4:0,1:-1) 22 ..S ECTYP=$P(EC,U,11),ECTOTC=0,ECDTTM=$$ECXTIME^ECXUTL($P(EC,U,5)) 23 .;looped thru all DAs for this order - now put it together 24 .;leave the next line in case the decision is made to send volume designations 25 .;I ECTYP="H" S ECTYP=ECTYP_$S(ECVOL'>1000:1,ECVOL'>2000:2,1:3) 26 .S ECXDSSI="" 27 .;loop thru tmp global and call pharmacy drug file (#50) api 28 .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 29 K ^TMP($J),CLIN,DA,DFN,DIC,DIK,DRG,ON,SA,X,Y,P1,P3 30 Q 31 STUFF ;get data 32 N ECORDST 33 S ECST=^TMP($J,SA,DRG),ECXCNT=^(DRG,1),ECXCOST=^(2),ECXCOST=ECXCOST*ECXCNT,ECVACL=$P(ECXPHA,U,2),ECORDST="" 34 ;if outpatient get division from iv rm; get dss identifier for clinic 35 I ECXA="O" D 36 .;- Only set ward to .5 if outpatient (but NOT observation patient) 37 .I $G(ECXW)="" S ECXW=.5 38 .I $P(EC,U,15) S ECIVRM=$P(EC,U,15),ECXDIV=$$PSJ59P5^ECXUTL5(ECIVRM) 39 .S CLIN=+$P(EC,U,13),(ECXP1,ECXP2)="000",ECXCL=$G(^ECX(728.44,CLIN,0)) Q:ECXCL="" 40 .S ECSC=$P(ECXCL,U,4),ECCSC=$P(ECXCL,U,5) 41 .I ECSC="" S ECSC=$P(ECXCL,U,2),ECCSC=$P(ECXCL,U,3) 42 .I ECSC S ECXP1=$$RJ^XLFSTR(ECSC,3,0),ECXP2=$$RJ^XLFSTR(ECCSC,3,0) 43 .I ECSC="" S ECSC=$P($G(^SC(ECXCL,0)),U,7),ECCSC=$P($G(^SC(ECXCL,0)),U,18) I ECSC D 44 ..S ECXP1=$P($G(^DIC(40.7,ECSC,0)),U,2) S:ECCSC]"" ECXP2=$P($G(^DIC(40.7,ECCSC,0)),U,2) 45 ..S ECXP1=$$RJ^XLFSTR(ECXP1,3,0),ECXP2=$$RJ^XLFSTR(ECXP2,3,0) 46 .S ECXDSSI=ECXP1_ECXP2 47 .I ECXLOGIC>2003 D 48 ..I "^18^23^24^36^41^65^94^"[("^"_ECXTS_"^") S ECXDSSI=$$TSMAP^ECXUTL4(ECXTS) 49 S ECINV=$P(ECXPHA,U,4),ECINV=$S(ECINV["I":"I",1:""),ECST=ECXCNT*ECST_" "_$P(ECST,U,2) 50 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) 51 S P1=$P(ECXPHA,U,5),P3=$P(ECXPHA,U,6) 52 S X="PSNAPIS" X ^%ZOSF("TEST") I $T S ECNFC=$$DSS^PSNAPIS(P1,P3,ECXYM)_ECNFC 53 I $L(ECNFC)=12 S ECNFC=$$RJ^XLFSTR(P1,4,0)_$$RJ^XLFSTR(P3,3,0)_ECNFC 54 ;- Ordering provider ("2"_provider) 55 S ECXORDPR=$S(+$P(EC,U,10):"2"_$P(EC,U,10),1:""),ECXOPNPI="" 56 S ECXORDDT=$P(EC,U,16) ;- Ordering date 57 ;- Requesting physician (null for FY2002) 58 S ECXRPHY="" 59 ;- Department and National Prod Division 60 S ECXDSSD="" ;dss department use postponed $$IVP^ECXDEPT(ECXDIV) 61 N ECXPDIV S ECXPDIV=$$GETDIV^ECXDEPT(ECXDIV) 62 ;- Observation patient indicator (yes/no) 63 S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXDSSI) 64 ; - Ordering Date, Ordering Stop Code 65 S ECXORDST="" I ECXA="O" D 66 .S ECXORDST=$$DOIVPO^ECXUTL5(DFN,ON) 67 .I ECXOBS="NO" S ECORDST="160" 68 .I ECXOBS="YES" S ECORDST=$P($G(^ECX(727.831,+ECXTS,0)),U,6) 69 ;- If no encounter number don't file record 70 S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADM,ECD,ECXTS,ECXOBS,ECHEAD,ECORDST,) 71 ;get BCMA data 72 S (ECXBCDD,ECXBCDG,ECXBCUA,ECXBCIF)="" 73 ;get ordering provider person class 74 S ECXOPPC=$$PRVCLASS^ECXUTL($E(ECXORDPR,2,999),ECXORDDT) 75 ;set national patient record flag if exist 76 S ECXDFN=DFN D NPRF^ECXUTL5 K ECXDFN 77 D:ECXENC'="" FILE K P1,P3 78 Q 79 PAT(ECXDFN,ECXDATE,ECXERR) ;get patient demographics, primary care, and inpatient data 80 N X 81 S (ECXCAT,ECXSTAT,ECXPRIOR,ECXSBGRP)="" 82 ;get patient data if saved 83 I $D(^TMP($J,"ECXP",ECXDFN)) D 84 .S PT=^TMP($J,"ECXP",ECXDFN),ECXPNM=$P(PT,U),ECXSSN=$P(PT,U,2),ECXMPI=$P(PT,U,3) 85 .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) 86 .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) 87 .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) 88 .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) 89 .S PT1=$G(^TMP($J,"ECXP",ECXDFN,1)),ECXERI=$P(PT1,U),ECXEST=$P(PT1,U,2) 90 .I $$ENROLLM^ECXUTL2(ECXDFN) 91 ;set patient data 92 I '$D(^TMP($J,"ECXP",ECXDFN)) D Q:'OK 93 .K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECXDATE,"."),"1;2;3;5",.ECXPAT) 94 .I 'OK K ECXPAT S ECXERR=1 Q 95 .S ECXPNM=ECXPAT("NAME"),ECXSSN=ECXPAT("SSN"),ECXMPI=ECXPAT("MPI"),ECXDOB=ECXPAT("DOB"),ECXELIG=ECXPAT("ELIG"),ECXSEX=ECXPAT("SEX") 96 .S ECXSTATE=ECXPAT("STATE"),ECXCNTY=ECXPAT("COUNTY"),ECXZIP=ECXPAT("ZIP"),ECXVET=ECXPAT("VET") 97 .S ECXPOS=ECXPAT("POS"),ECXPST=ECXPAT("POW STAT"),ECXPLOC=ECXPAT("POW LOC"),ECXRST=ECXPAT("IR STAT") 98 .S ECXAST=ECXPAT("AO STAT"),ECXAOL=ECXPAT("AOL"),ECXPHI=ECXPAT("PHI"),ECXMST=ECXPAT("MST STAT") 99 .S ECXENRL=ECXPAT("ENROLL LOC"),ECXMTST=ECXPAT("MEANS"),ECXEST=ECXPAT("EC STAT") 100 .S ECXCNHU=$$CNHSTAT^ECXUTL4(ECXDFN) ;get CNHU status 101 .;get enrollment data (category, status and priority) 102 .I $$ENROLLM^ECXUTL2(ECXDFN) 103 .S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) ;Head and Neck Cancer Indicator 104 .; - Race and Ethnicity 105 .S ECXETH=ECXPAT("ETHNIC"),ECXRC1=ECXPAT("RACE1") 106 .S ECXERI=ECXPAT("ERI") ;emergency response indicator (FEMA) 107 .;save for later 108 .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 109 .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 110 .S ^TMP($J,"ECXP",ECXDFN,1)=ECXERI_U_ECXEST 111 ;get primary care data 112 S X=$$PRIMARY^ECXUTL2(ECXDFN,$P(ECXDATE,".")) 113 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) 114 ;get inpatient data 115 S (ECXA,ECXMN,ECXADM,ECXTS,ECXW,ECXDIV)="",X=$$INP^ECXUTL2(ECXDFN,ECXDATE) 116 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) 117 Q 118 FILE ;file record 119 ;node0 120 ;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^ 121 ;primary care team^primary care provider^ivp time^adm date^adm time^dss identifier 122 ;node1 123 ;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^ 124 ;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^ 125 ;ao loc^purple heart ind.^mst stat^enrollment loc^enrollment cat^enrollment stat^enrollment prior^cnh/sh stat^ord pr npi 126 ;node2 127 ;head & neck cancer ind.^ethnicity^race1^bcma drug dispensed^bcma dose given^bcma unit of administration^bcma ICU flag^ 128 ;ordering provider person class^^user enrollee ECXUESTA^patient type ECXPTYPE^combat vet elig ECXCVE^ 129 ;combat vet elig end date ECXCVEDT^enc cv eligible ECXCVENC^national patient record flag ECXNPRFI^emerg resp indic(FEMA) ECXERI^ 130 ;environ contamin ECXEST 131 N DA,DIK 132 S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 133 S ECODE=EC7_U_EC23_U_ECXDIV_U_DFN_U_ECXSSN_U_ECXPNM_U_ECXA_U 134 S ECODE=ECODE_$$ECXDATE^ECXUTL(ECD,ECXYM)_U_ECVACL_U_ECXCNT_U_ECXW_U 135 ;convert specialty to PTF Code for transmission 136 N ECXDATA 137 S ECXDATA=$$TSDATA^DGACT(42.4,+ECXTS,.ECXDATA) 138 S ECXTS=$G(ECXDATA(7)) 139 ;done 140 S ECODE=ECODE_ECXCOST_U_ECXMN_U_ECXTS_U_ECNDC_U_ECINV_U_ECTYP_U_ECNFC_U 141 S ECODE=ECODE_ECST_U_ECPTTM_U_ECPTPR_U_ECDTTM_U_$$ECXDATE^ECXUTL(ECXADM,ECXYM)_U_$$ECXTIME^ECXUTL(ECXADM)_U_ECXDSSI_U 142 ;if outpat and not observ patient, admit date="" and admit time="000000" 143 I ECXA="O",(ECXOBS="NO") S $P(ECODE,U,24)="",$P(ECODE,U,25)="000000" 144 S ECODE1=ECXMPI_U_ECXDSSD_U_ECPTNPI_U_ECCLAS_U_ECASPR_U_ECCLAS2_U_ECASNPI_U_ECXDOM_U_ECXOBS_U_ECXENC_U_ECXORDPR_U 145 S ECODE1=ECODE1_ECXORDST_U_$$ECXDATE^ECXUTL(ECXORDDT,ECXYM)_U_ECXRPHY_U_ECXPDIV_U_ECXMTST_U_ECXELIG_U_ECXDOB_U 146 S ECODE1=ECODE1_ECXSEX_U_ECXSTATE_U_ECXCNTY_U_ECXZIP_U_ECXVET_U_ECXPOS_U_ECXPST_U_ECXPLOC_U_ECXRST_U_ECXAST_U 147 S ECODE1=ECODE1_ECXAOL_U_ECXPHI_U_ECXMST_U_ECXENRL_U_ECXCAT_U 148 S ECODE1=ECODE1_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXCNHU_U_ECXOPNPI_U 149 S ECODE2=ECXHNCI_U_ECXETH_U_ECXRC1 150 I ECXLOGIC>2003 D 151 .S ECODE2=ECODE2_U_ECXBCDD_U_ECXBCDG_U_ECXBCUA_U_ECXBCIF_U_ECXOPPC 152 I ECXLOGIC>2004 S ECODE2=ECODE2_U_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXNPRFI 153 I ECXLOGIC>2006 S ECODE2=ECODE2_U_ECXERI_U_ECXEST 154 S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1 155 S ^ECX(ECFILE,EC7,2)=ECODE2,ECRN=ECRN+1 156 S DA=EC7,DIK="^ECX("_ECFILE_"," D IX^DIK K DIK,DA 157 I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 158 Q 159 SETUP ;Set required input for ECXTRAC 160 S ECHEAD="IVP" 161 D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) 162 ;variables ecver and ecrtn will be reset in routine ecxtrac if appropriate 163 S ECVER=7 164 Q 165 QUE ; entry point for the background requeuing handled by ECXTAUTO 166 D SETUP,QUE^ECXTAUTO,^ECXKILL Q -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXPLBB.m
r613 r623 1 ECXPLBB ;DALOI/KML - DSS BLOOD BANK PRE-EXTRACT AUDIT REPORT ; 8/13/07 7:08am2 ;;3.0;DSS EXTRACTS;**78,92,105**;Dec 22, 1997;Build 703 4 5 6 7 8 9 10 11 START 12 13 14 15 16 17 18 19 20 21 OUTPUT 22 23 24 25 26 27 28 29 30 PRINT 31 32 33 34 35 36 37 38 39 HED 40 41 W !,"LBBExtract Audit Report",?72,"Page",$J(ECPG,3)42 43 44 45 46 47 48 DATES 49 50 51 52 W @IOF,!,"LBBExtract Audit Report Information for DSS",!!53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 QUE 73 74 75 76 77 78 79 80 S ZTDESC=ECPACK_"EXTRACT AUDIT REPORT: "_ECSDN_" TO "_ECEDN,ZTRTN="START^ECXPLBB",ZTIO=""81 82 83 84 EN(ECXJOB,ECSD,ECED) 85 86 87 88 89 90 91 92 93 94 95 96 97 98 1 ECXPLBB ;DALOI/KML - DSS BLOOD BANK PRE-EXTRACT AUDIT REPORT ; 8/14/06 10:10am 2 ;;3.0;DSS EXTRACTS;**78,92**;Dec 22, 1997;Build 30 3 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021 4 ;entry point from option 5 D SETUP^ECXLBB I ECFILE="" Q 6 N ECXINST 7 D DATES 8 Q:ECED']""&(ECSD']"") 9 N ECXPOP S ECXPOP=0 D QUE Q:ECXPOP 10 ; 11 START ; entry point from tasked job 12 ; get LAB DATA and build temporary global ^TMP("ECXLBB",$J) 13 N ECTRSP,ECADMT,ECTODT,ECXRPT,ECOUT,ECXSTR,ECRDT,ECLINE,ECPG,ECQUIT 14 N ECD,ECXDFN,ECARRY,EC66,ECERR,ECTRFDT,ECTRFTM,ECX,ECINOUT,ECXJOB 15 N ECXLOGIC 16 S ECXJOB=$J 17 K ^TMP("ECXLBB",ECXJOB) 18 U IO 19 I $E(IOST,1,2)="C-" W !,"Retrieving records... " 20 S ECXRPT=1 D AUDRPT^ECXLBB 21 OUTPUT ; entry point called by EN tag 22 I '$D(^TMP("ECXLBB",ECXJOB)) W !,"There were no records that met the date range criteria" Q 23 S (ECPG,ECDATE,ECQUIT,ECXDFN)=0,ECLINE="",$P(ECLINE,"=",80)="=" 24 S ECSDN=$$FMTE^XLFDT(ECSD,9),ECEDN=$$FMTE^XLFDT(ECED,9),ECRDT=$$FMTE^XLFDT(DT,9) 25 W:$E(IOST,1,2)="C-" @IOF D HED 26 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 27 D ^ECXKILL 28 Q 29 ; 30 PRINT ; 31 I $Y+5>IOSL D Q:ECQUIT 32 . I $E(IOST,1,2)["C-" S DIR(0)="E" D ^DIR K DIR I 'Y S ECQUIT=1 Q 33 . W @IOF D HED 34 W !,$P(ECXSTR,"^",5),?11,$P(ECXSTR,"^",4),?26,$P(ECXSTR,"^",16) 35 W ?37,$$FMTE^XLFDT($$HL7TFM^XLFDT($P(ECXSTR,"^",8)),2) 36 W ?49,$P(ECXSTR,"^",11),?60,$J(+$P(ECXSTR,"^",12),2) 37 Q 38 ; 39 HED ; 40 S ECPG=ECPG+1 41 W !,"LBB Pre-Extract Audit Report",?72,"Page",$J(ECPG,3) 42 W !,ECSDN," - ",ECEDN,?58,"Run Date:",$J(ECRDT,12) 43 W !,?37,"Transf",?57,"Number" 44 W !,"Name",?14,"SSN",?25,"FDR LOC",?37,"Date",?49,"COMP" 45 W ?57,"of Units" 46 W !,ECLINE 47 Q 48 DATES ; 49 N OUT,CHKFLG 50 I '$D(ECNODE) S ECNODE=7 51 I '$D(ECHEAD) S ECHEAD=" " 52 W @IOF,!,"LBB Pre-Extract Audit Report Information for DSS",!! 53 S:'$D(ECINST) ECINST=+$P(^ECX(728,1,0),U) 54 S ECXINST=ECINST 55 K ECXDIC S DA=ECINST,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99" 56 D EN^DIQ1 S ECINST=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC 57 S ECLDT=$S($D(^ECX(728,1,ECNODE)):$P(^(ECNODE),U,ECPIECE),1:2610624) 58 S:ECLDT="" ECLDT=2610624 59 S ECOUT=0 F S (ECED,ECSD)="" D Q:ECOUT 60 . K %DT S %DT="AEX",%DT("A")="Starting with Date: " D ^%DT 61 . I Y<0 S ECOUT=1 Q 62 . S ECSD=Y 63 . K %DT S %DT="AEX",%DT("A")="Ending with Date: " D ^%DT 64 . I Y<0 S ECOUT=1 Q 65 . I Y<ECSD W !!,"The ending date cannot be earlier than the starting date.",!,"Please try again.",!! Q 66 . I $E(Y,1,5)'=$E(ECSD,1,5) W !!,"Beginning and ending dates must be in the same month and year.",!,"Please try again.",!! Q 67 . S ECED=Y 68 . I ECLDT'<ECSD W !!,"The Blood Bank information has already been extracted through ",$$FMTE^XLFDT(ECLDT),".",!,"Please enter a new date range.",!! Q 69 . S ECOUT=1 70 Q 71 ; 72 QUE ; 73 K ZTSAVE 74 S ECSDN=$$FMTE^XLFDT(ECSD),ECEDN=$$FMTE^XLFDT(ECED),ECSD1=ECSD-.1 75 K ZTSAVE 76 F X="ECINST","ECED","ECSD","ECSD1","ECEDN","ECSDN" S ZTSAVE(X)="" 77 F X="ECPACK","ECPIECE","ECRTN","ECGRP","ECNODE" S ZTSAVE(X)="" 78 F X="ECFILE","ECHEAD","ECVER","ECINST","ECXINST" S ZTSAVE(X)="" 79 F X="ECXLOGIC","ECXDATES" S ZTSAVE(X)="" 80 S ZTDESC=ECPACK_" PRE-EXTRACT AUDIT REPORT: "_ECSDN_" TO "_ECEDN,ZTRTN="START^ECXPLBB",ZTIO="" 81 S IOP="Q" W ! S %ZIS="QMP" D ^%ZIS S:POP ECXPOP=1 Q:POP I $D(IO("Q")) K IO("Q"),ZTIO D ^%ZTLOAD W:$D(ZTSK) !,$C(7),"REQUEST QUEUED",!,"Task #: ",$G(ZTSK) K I,ZTSK,ZTIO,ZTSAVE,ZTRTN D HOME^%ZIS S ECXPOP=1 82 Q 83 ; 84 EN(ECXJOB,ECSD,ECED) ; entry point used primarily for testing 85 ; input: 86 ; ECXJOB = $J that is assigned to the 2nd subscript of 87 ; the temporary global array containing the 88 ; extracted data that feeds the pre-extract 89 ; audit report 90 ; ECSD = starting date range representing the FM 91 ; date used to retrieve data from file #63 92 ; ECED = ending date range representing the FM date 93 ; used to retrieve data from file #63 94 ; syntax of the call: D EN^ECXPLBB(541571372,3000101,3000131) 95 D OUTPUT 96 Q 97 ; 98 ;ECXPLBB -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXPRO.m
r613 r623 1 ECXPRO ;ALB/GTS - Prosthetics Extract for DSS ; 10/17/07 3:47pm 2 ;;3.0;DSS EXTRACTS;**9,13,15,21,24,33,39,46,71,92,105**;Dec 22, 1997;Build 70 3 BEG ;entry point from option 4 D SETUP I ECFILE="" Q 5 D:+ECINST>0 ^ECXTRAC D ^ECXKILL 6 Q 7 ; 8 START ;start package specific extract 9 ; 10 ; Input 11 ; ECSD1 - FM formatted Beginning Date (Set by ECXTRAC) 12 ; ECED - FM formatted End Date (Set by ECXTRAC) 13 ; ECSDN - Externally formatted Start Date (Set by ECXTRAC) 14 ; ECEDN - Externally formatted End Date (Set by ECXTRAC) 15 ; EC - IEN from file #727 (Set by ECXTRAC) 16 ; ECXYM - Year and Month of extract (YYYYMM) 17 ; ECXINST - IEN for division in file #4 18 ; ECINST - Station number of selected division 19 ; 20 N ECXLNE,ECXCT,ECXDACT,ECX0,ECXLB,ECXED1,ECINSTSV,ECXLNSTR,ECXP 21 N DIC,DR,DA,DIQ,CPTCODE,ECXNPRFI 22 D ECXBUL^ECXPRO2(.ECXLNE,ECSDN,ECEDN,EC) 23 S QFLG=0,ECXLNSTR=ECXLNE,ECXED1=ECED+.9999,ECXCT=ECSD1 24 F S ECXCT=$O(^RMPR(660,"CT",ECXCT)) Q:(ECXCT>ECXED1)!('ECXCT)!(QFLG=1) D 25 .S ECXDACT=0 26 .F S ECXDACT=$O(^RMPR(660,"CT",ECXCT,ECXDACT)) Q:('ECXDACT)!(QFLG=1) D 27 ..;* initialize variables 28 ..S (ECXDFN,ECXPNM,ECXSSN,ECXSEX,ECXSTAT,ECXDATE,ECXTYPE,ECXSRCE)="" 29 ..S (ECXHCPCS,ECXPHCPC,ECXRQST,ECXRCST,ECXFORM,ECXCTAMT,ECXLLC)="" 30 ..S (ECXLMC,ECXGRPR,ECXBILST,ECXQTY,ECXFELOC,ECXFEKEY,ECXA)="" 31 ..S (ECPTTM,ECPTPR,ECXAST,ECXRST,ECXEST,ECXELIG,ECXVET,ECXZIP)="" 32 ..S (ECXDOB,ECXDSSD,ECXICD9,ECXAOL,ECXHNCI,ECXETH,ECXRC1,ECXMST)="" 33 ..F I=1:1:4 S @("ECXICD9"_I)="" 34 ..Q:'$D(^RMPR(660,ECXDACT,0)) 35 ..S ECX0=^RMPR(660,ECXDACT,0),ECXLB=$G(^RMPR(660,ECXDACT,"LB")) 36 ..K ECXP S DIC="^RMPR(660,",DR=".02;11",DA=ECXDACT,DIQ(0)="EI" 37 ..S DIQ="ECXP" D EN^DIQ1 38 ..S ECXDIV=$$GET1^DIQ(660,ECXDACT,8,"I") 39 ..S ECXDFN=$G(ECXP(660,ECXDACT,.02,"I")) 40 ..S ECXFORM=$G(ECXP(660,ECXDACT,11,"E"))_U_$G(ECXP(660,ECXDACT,11,"I")) 41 ..Q:'$$PATDEM^ECXUTL2(ECXDFN,ECXCT) 42 ..S OK=$$PAT^ECXUTL3(ECXDFN,ECXDATE,"1;5",.ECXPAT) 43 ..I 'OK S ECXERR=1 K ECXPAT Q 44 ..;OEF/OIF data 45 ..S ECXOEF=ECXPAT("ECXOEF") 46 ..S ECXOEFDT=ECXPAT("ECXOEFDT") 47 ..Q:'$$NTEG^ECXPRO1(ECXDFN,.ECXLNE,ECXDACT,ECX0,ECXLB,ECINST,ECXFORM) 48 ..D PROSINFO^ECXPRO1(ECXDACT,ECXLB,ECX0,ECXFORM) 49 ..S CPTCODE=$E(ECXHCPCS,1,5) 50 ..;nppd entry date 51 ..S ECXNPPDT=$$ECXDATE^ECXUTL($P(ECX0,U,1),ECXYM) 52 ..; 53 ..;Get production division ;p-46 54 ..N ECXPDIV S ECXPDIV=$$RADDIV^ECXDEPT(ECXDIV) ;p-46 55 ..;- Observation patient indicator (YES/NO) 56 ..S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS) 57 ..; 58 ..;- CNH status (YES/NO) 59 ..S ECXCNH=$$CNHSTAT^ECXUTL4(ECXDFN) 60 ..; 61 ..;get encounter classifications 62 ..S (ECXAO,ECXECE,ECXHNC,ECXMIL,ECXIR)="" 63 ..S ECXVISIT=$$GET1^DIQ(660,ECXDACT,8.12,"I") I ECXVISIT'="" D 64 ...D VISIT^ECXSCX1(ECXDFN,ECXVISIT,.ECXVIST,.ECXERR) I ECXERR K ECXERR Q 65 ...S ECXAO=$G(ECXVIST("AO")),ECXECE=$G(ECXVIST("PGE")) 66 ...S ECXHNC=$G(ECXVIST("HNC")),ECXMIL=$G(ECXVIST("MST")),ECXIR=$G(ECXVIST("IR")) 67 ..; - Head and Neck Cancer Indicator 68 ..S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) 69 ..; 70 ..; - set national patient record flag if exist 71 ..D NPRF^ECXUTL5 72 ..; 73 ..;- If no encounter number don't file record 74 ..S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,,) Q:ECXENC="" 75 ..I ECXFORM["-3" F ECXLAB="LAB","ORD" D 76 ...D FEEDINFO^ECXPRO2(ECXSRCE,CPTCODE,ECXTYPE,ECXSTAT2,ECXRQST,ECXRCST,ECXLAB) 77 ...Q:ECXFELOC="" D FILE 78 ..I ECXFORM'["-3" S ECXLAB="NONL" D 79 ...D FEEDINFO^ECXPRO2(ECXSRCE,CPTCODE,ECXTYPE,ECXSTAT2,ECXRQST,ECXRCST,ECXLAB) 80 ...Q:ECXFELOC="" D FILE 81 ;* Send the Exception message 82 I ECXLNSTR<ECXLNE DO 83 .K XMY S XMY("G.DSS-"_ECGRP_"@"_^XMB("NETNAME"))="" 84 .S XMDUZ=.5 85 .S XMSUB=ECINST_" - Prosthetics DSS Exception Message",XMN=0 86 .S XMTEXT="^TMP(""ECX-PRO EXC"",$J," 87 .D ^XMD 88 K ^TMP("ECX-PRO EXC",$J),XMDUZ,XMSUB,XMTEXT,XMY 89 Q 90 ; 91 FILE ;file extract record 92 ;node0 93 ;facility^dfn (ECXDFN)^ssn (ECXSSN)^name (ECXPNM)^in/out (ECXA)^ 94 ;day^feeder location^ 95 ;feeder key^qty^pc team^pc provider^hcpcs^icd9 (ECXICD9)^ 96 ;icd9-1 (ECXICD91)^icd9-2 (ECXICD92)^icd9-3 (ECXICD93)^ 97 ;icd9-4 (ECXICD94)^agent orange^radiation^env contam^eligibility^ 98 ;cost^lab labor cost^lab matl cost^billing status^ 99 ;vet^transaction type^req station^rec station^file#661.1 ien 100 ;node1 101 ;zip^dob^sex^amis grouper^placeholder^mpi^dss dept ECXDSSD^ 102 ;pc prov person class^race^pow status^pow loc^ 103 ;sharing agree payor^sharing agree ins^mst status^ 104 ;enroll loc^state^county^assoc pc provider^ 105 ;assoc pc prov person class^placeholder 106 ;dom (ECXDOM)^purple heart indicator (ECXPHI)^ 107 ;enrollment Category (ECXCAT)^enrollment status (ECXSTAT)^ 108 ;enrollment priority (ECXPRIOR)^purple heart ind (ECXPHI)^ 109 ;period of serv (ECXPOS)^observ pat ind (ECXOBS)^encounter num (ECXENC)^ 110 ;ao loc (ECXAOL)^CNH status (ECXCNH)^production division ECXPDIV^ 111 ;head & neck canc. ind. (ECXHNCI)^ethnicity (ECXETH)^race1 (ECXRC1)^ 112 ;^enrollment priority (ECXPRIOR)_enrollment sub- 113 ;group (ECXSBGRP)^user enrollee (ECXUESTA)^patient type ECXPTYPE 114 ;^combat vet elig ECXCVE^combat vet elig end date ECXCVEDT^enc cv 115 ;eligible ECXCVENC^national patient record flag ECXNPRFI^ 116 ;emergency response indicator(FEMA) ECXERI^agent orange indicator ECXAO 117 ;^environ contam ECXECE^head/neck cancer ECXHNC^encntr mst ECXMIL^ 118 ;radiation ECXIR^OEF/OIF ECXOEF^OEF/OIF return date ECXOEFDT^ 119 ;nppd code ECXNPPDC^nppd entry date ECXNPPDT 120 ;assoc pc provider npi ECASNPI^primary care provider npi ECPTNPI 121 N DA,DIK 122 S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 123 S ECODE=EC7_U_EC23_U_ECINST_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U 124 S ECODE=ECODE_$$ECXDATE^ECXUTL(ECXDATE,ECXYM)_U_ECXFELOC_U 125 S ECODE=ECODE_ECXFEKEY_U_ECXQTY_U_ECPTTM_U_ECPTPR_U_ECXHCPCS_U 126 S ECODE=ECODE_ECXICD9_U_ECXICD91_U_ECXICD92_U_ECXICD93_U_ECXICD94_U 127 S ECODE=ECODE_ECXAST_U_ECXRST_U_ECXEST_U_ECXELIG_U_ECXCTAMT_U_ECXLLC_U 128 S ECODE=ECODE_ECXLMC_U_ECXBILST_U_ECXVET_U_ECXTYPE_U_ECXRQST_U_ECXRCST_U 129 S ECODE=ECODE_ECXPHCPC_U 130 S ECODE1=ECXZIP_U_ECXDOB_U_ECXSEX_U_ECXGRPR_U_U_ECXMPI_U 131 S ECODE1=ECODE1_ECXDSSD_U_ECCLAS_U_ECXRACE_U_ECXPST_U_ECXPLOC_U 132 S ECODE1=ECODE1_U_U_ECXMST_U_ECXENRL_U_ECXSTATE_U 133 S ECODE1=ECODE1_ECXCNTY_U_ECASPR_U_ECCLAS2_U_U_ECXDOM_U 134 S ECODE1=ECODE1_ECXCAT_U_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXPHI_U_ECXPOS_U 135 S ECODE1=ECODE1_ECXOBS_U_ECXENC_U_ECXAOL_U_ECXCNH_U_ECXPDIV_U 136 S ECODE1=ECODE1_ECXHNCI_U_ECXETH_U_ECXRC1_U 137 I ECXLOGIC>2004 S ECODE1=ECODE1_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXNPRFI 138 I ECXLOGIC>2006 S ECODE1=ECODE1_U_ECXERI_U_ECXAO_U_ECXECE_U_ECXHNC_U_ECXMIL_U_ECXIR_U 139 I ECXLOGIC>2007 S ECODE2=ECXOEF_U_ECXOEFDT_U_ECXNPPDC_U_ECXNPPDT_U_ECASNPI_U_ECPTNPI 140 S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,^ECX(ECFILE,EC7,2)=$G(ECODE2),ECRN=ECRN+1 141 S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA 142 I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 143 Q 144 SETUP ;Set required input for ECXTRAC 145 S ECHEAD="PRO" 146 D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) 147 S ECINST=$$PDIV^ECXPUTL 148 Q 149 ; 150 ;**Note: LOCAL and QUE are carry over from protocols set by other 151 ; routines. 152 LOCAL ;to extract nightly for local use not to be transmitted to TSI 153 ;QUEUE with 1D frequency 154 D SETUP,^ECXTLOCL,^ECXKILL Q 155 ; 156 QUE ; entry point for the background requeuing handled by ECXTAUTO 157 D SETUP,QUE^ECXTAUTO,^ECXKILL Q 1 ECXPRO ;ALB/GTS - Prosthetics Extract for DSS ; 11/2/06 8:56am 2 ;;3.0;DSS EXTRACTS;**9,13,15,21,24,33,39,46,71,92**;Dec 22, 1997;Build 30 3 BEG ;entry point from option 4 D SETUP I ECFILE="" Q 5 D:+ECINST>0 ^ECXTRAC D ^ECXKILL 6 Q 7 ; 8 START ;start package specific extract 9 ; 10 ; Input 11 ; ECSD1 - FM formatted Beginning Date (Set by ECXTRAC) 12 ; ECED - FM formatted End Date (Set by ECXTRAC) 13 ; ECSDN - Externally formatted Start Date (Set by ECXTRAC) 14 ; ECEDN - Externally formatted End Date (Set by ECXTRAC) 15 ; EC - IEN from file #727 (Set by ECXTRAC) 16 ; ECXYM - Year and Month of extract (YYYYMM) 17 ; ECXINST - IEN for division in file #4 18 ; ECINST - Station number of selected division 19 ; 20 N ECXLNE,ECXCT,ECXDACT,ECX0,ECXLB,ECXED1,ECINSTSV,ECXLNSTR,ECXP 21 N DIC,DR,DA,DIQ,CPTCODE,ECXNPRFI 22 D ECXBUL^ECXPRO2(.ECXLNE,ECSDN,ECEDN,EC) 23 S QFLG=0,ECXLNSTR=ECXLNE,ECXED1=ECED+.9999,ECXCT=ECSD1 24 F S ECXCT=$O(^RMPR(660,"CT",ECXCT)) Q:(ECXCT>ECXED1)!('ECXCT)!(QFLG=1) D 25 .S ECXDACT=0 26 .F S ECXDACT=$O(^RMPR(660,"CT",ECXCT,ECXDACT)) Q:('ECXDACT)!(QFLG=1) D 27 ..;* initialize variables 28 ..S (ECXDFN,ECXPNM,ECXSSN,ECXSEX,ECXSTAT,ECXDATE,ECXTYPE,ECXSRCE)="" 29 ..S (ECXHCPCS,ECXPHCPC,ECXRQST,ECXRCST,ECXFORM,ECXCTAMT,ECXLLC)="" 30 ..S (ECXLMC,ECXGRPR,ECXBILST,ECXQTY,ECXFELOC,ECXFEKEY,ECXA)="" 31 ..S (ECPTTM,ECPTPR,ECXAST,ECXRST,ECXEST,ECXELIG,ECXVET,ECXZIP)="" 32 ..S (ECXDOB,ECXDSSD,ECXICD9,ECXAOL,ECXHNCI,ECXETH,ECXRC1,ECXMST)="" 33 ..F I=1:1:4 S @("ECXICD9"_I)="" 34 ..Q:'$D(^RMPR(660,ECXDACT,0)) 35 ..S ECX0=^RMPR(660,ECXDACT,0),ECXLB=$G(^RMPR(660,ECXDACT,"LB")) 36 ..K ECXP S DIC="^RMPR(660,",DR=".02;11",DA=ECXDACT,DIQ(0)="EI" 37 ..S DIQ="ECXP" D EN^DIQ1 38 ..S ECXDIV=$$GET1^DIQ(660,ECXDACT,8,"I") 39 ..S ECXDFN=$G(ECXP(660,ECXDACT,.02,"I")) 40 ..S ECXFORM=$G(ECXP(660,ECXDACT,11,"E"))_U_$G(ECXP(660,ECXDACT,11,"I")) 41 ..Q:'$$PATDEM^ECXUTL2(ECXDFN,ECXCT) 42 ..Q:'$$NTEG^ECXPRO1(ECXDFN,.ECXLNE,ECXDACT,ECX0,ECXLB,ECINST,ECXFORM) 43 ..D PROSINFO^ECXPRO1(ECXDACT,ECXLB,ECX0,ECXFORM) 44 ..S CPTCODE=$E(ECXHCPCS,1,5) 45 ..; 46 ..;Get production division ;p-46 47 ..N ECXPDIV S ECXPDIV=$$RADDIV^ECXDEPT(ECXDIV) ;p-46 48 ..;- Observation patient indicator (YES/NO) 49 ..S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS) 50 ..; 51 ..;- CNH status (YES/NO) 52 ..S ECXCNH=$$CNHSTAT^ECXUTL4(ECXDFN) 53 ..; 54 ..;get encounter classifications 55 ..S (ECXAO,ECXECE,ECXHNC,ECXMIL,ECXIR)="" 56 ..S ECXVISIT=$$GET1^DIQ(660,ECXDACT,8.12,"I") I ECXVISIT'="" D 57 ...D VISIT^ECXSCX1(ECXDFN,ECXVISIT,.ECXVIST,.ECXERR) I ECXERR K ECXERR Q 58 ...S ECXAO=$G(ECXVIST("AO")),ECXECE=$G(ECXVIST("PGE")) 59 ...S ECXHNC=$G(ECXVIST("HNC")),ECXMIL=$G(ECXVIST("MST")),ECXIR=$G(ECXVIST("IR")) 60 ..; - Head and Neck Cancer Indicator 61 ..S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) 62 ..; 63 ..; - set national patient record flag if exist 64 ..D NPRF^ECXUTL5 65 ..; 66 ..;- If no encounter number don't file record 67 ..S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,,) Q:ECXENC="" 68 ..I ECXFORM["-3" F ECXLAB="LAB","ORD" D 69 ...D FEEDINFO^ECXPRO2(ECXSRCE,CPTCODE,ECXTYPE,ECXSTAT2,ECXRQST,ECXRCST,ECXLAB) 70 ...Q:ECXFELOC="" D FILE 71 ..I ECXFORM'["-3" S ECXLAB="NONL" D 72 ...D FEEDINFO^ECXPRO2(ECXSRCE,CPTCODE,ECXTYPE,ECXSTAT2,ECXRQST,ECXRCST,ECXLAB) 73 ...Q:ECXFELOC="" D FILE 74 ;* Send the Exception message 75 I ECXLNSTR<ECXLNE DO 76 .K XMY S XMY("G.DSS-"_ECGRP_"@"_^XMB("NETNAME"))="" 77 .S XMDUZ=.5 78 .S XMSUB=ECINST_" - Prosthetics DSS Exception Message",XMN=0 79 .S XMTEXT="^TMP(""ECX-PRO EXC"",$J," 80 .D ^XMD 81 K ^TMP("ECX-PRO EXC",$J),XMDUZ,XMSUB,XMTEXT,XMY 82 Q 83 ; 84 FILE ;file extract record 85 ;node0 86 ;facility^dfn (ECXDFN)^ssn (ECXSSN)^name (ECXPNM)^in/out (ECXA)^ 87 ;day^feeder location^ 88 ;feeder key^qty^pc team^pc provider^hcpcs^icd9 (ECXICD9)^ 89 ;icd9-1 (ECXICD91)^icd9-2 (ECXICD92)^icd9-3 (ECXICD93)^ 90 ;icd9-4 (ECXICD94)^agent orange^radiation^env contam^eligibility^ 91 ;cost^lab labor cost^lab matl cost^billing status^ 92 ;vet^transacton type^req station^rec station^file#661.1 ien 93 ;node1 94 ;zip^dob^sex^amis grouper^pc prov npi^mpi^dss dept ECXDSSD^ 95 ;pc prov person class^race^pow status^pow loc^ 96 ;sharing agree payor^sharing agree ins^mst status^ 97 ;enroll loc^state^county^assoc pc provider^ 98 ;assoc pc prov person class^assoc pc prov npi 99 ;dom (ECXDOM)^purple heart indicator (ECXPHI)^ 100 ;enrollment Category (ECXCAT)^enrollment status (ECXSTAT)^ 101 ;enrollment priority (ECXPRIOR)^purple heart ind (ECXPHI)^ 102 ;period of serv (ECXPOS)^observ pat ind (ECXOBS)^encounter num (ECXENC)^ 103 ;ao loc (ECXAOL)^CNH status (ECXCNH)^production division ECXPDIV^ 104 ;head & neck canc. ind. (ECXHNCI)^ethnicity (ECXETH)^race1 (ECXRC1)^ 105 ;^enrollment priority (ECXPRIOR)_enrollment sub- 106 ;group (ECXSBGRP)^user enrollee (ECXUESTA)^patient type ECXPTYPE 107 ;^combat vet elig ECXCVE^combat vet elig end date ECXCVEDT^enc cv 108 ;eligible ECXCVENC^national patient record flag ECXNPRFI^ 109 ;emergency response indicator(FEMA) ECXERI^agent orange indicator ECXAO 110 ;^environ contam ECXECE^head/neck cancer ECXHNC^encntr mst ECXMIL^ 111 ;radiation ECXIR 112 N DA,DIK 113 S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 114 S ECODE=EC7_U_EC23_U_ECINST_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U 115 S ECODE=ECODE_$$ECXDATE^ECXUTL(ECXDATE,ECXYM)_U_ECXFELOC_U 116 S ECODE=ECODE_ECXFEKEY_U_ECXQTY_U_ECPTTM_U_ECPTPR_U_ECXHCPCS_U 117 S ECODE=ECODE_ECXICD9_U_ECXICD91_U_ECXICD92_U_ECXICD93_U_ECXICD94_U 118 S ECODE=ECODE_ECXAST_U_ECXRST_U_ECXEST_U_ECXELIG_U_ECXCTAMT_U_ECXLLC_U 119 S ECODE=ECODE_ECXLMC_U_ECXBILST_U_ECXVET_U_ECXTYPE_U_ECXRQST_U_ECXRCST_U 120 S ECODE=ECODE_ECXPHCPC_U 121 S ECODE1=ECXZIP_U_ECXDOB_U_ECXSEX_U_ECXGRPR_U_ECPTNPI_U_ECXMPI_U 122 S ECODE1=ECODE1_ECXDSSD_U_ECCLAS_U_ECXRACE_U_ECXPST_U_ECXPLOC_U 123 S ECODE1=ECODE1_U_U_ECXMST_U_ECXENRL_U_ECXSTATE_U 124 S ECODE1=ECODE1_ECXCNTY_U_ECASPR_U_ECCLAS2_U_ECASNPI_U_ECXDOM_U 125 S ECODE1=ECODE1_ECXCAT_U_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXPHI_U_ECXPOS_U 126 S ECODE1=ECODE1_ECXOBS_U_ECXENC_U_ECXAOL_U_ECXCNH_U_ECXPDIV_U 127 S ECODE1=ECODE1_ECXHNCI_U_ECXETH_U_ECXRC1_U 128 I ECXLOGIC>2004 S ECODE1=ECODE1_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXNPRFI 129 I ECXLOGIC>2006 S ECODE1=ECODE1_U_ECXERI_U_ECXAO_U_ECXECE_U_ECXHNC_U_ECXMIL_U_ECXIR 130 S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,ECRN=ECRN+1 131 S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA 132 I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 133 Q 134 SETUP ;Set required input for ECXTRAC 135 S ECHEAD="PRO" 136 D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) 137 S ECINST=$$PDIV^ECXPUTL 138 Q 139 ; 140 ;**Note: LOCAL and QUE are carry over from protocols set by other 141 ; routines. 142 LOCAL ;to extract nightly for local use not to be transmitted to TSI 143 ;QUEUE with 1D frequency 144 D SETUP,^ECXTLOCL,^ECXKILL Q 145 ; 146 QUE ; entry point for the background requeuing handled by ECXTAUTO 147 D SETUP,QUE^ECXTAUTO,^ECXKILL Q -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXPRO1.m
r613 r623 1 ECXPRO1 ;ALB/GTS - Prosthetics Extract for DSS (Continued) ; 11/8/07 8:02am 2 ;;3.0;DSS EXTRACTS;**9,11,13,15,21,24,33,37,39,100,105**;Dec 22, 1997;Build 70 3 ; 4 NTEG(ECXDFN,ECXLNE,ECXPIEN,ECXN0,ECXNLB,ECINST,ECXFORM) ;** Check for required fields 5 ; Input 6 ; ECXDFN - ien in file #2 7 ; ECXLNE - line number variable (passed by reference) 8 ; ECXPIEN - IEN for the Prosthetics record 9 ; ECXN0 - zero node of the Prosthetics record 10 ; ECXNLB - LB node of the Prosthetics record 11 ; ECINST - station number being extracted 12 ; ECXFORM - Form Requested On 13 ; Output (to be KILLed by calling routine) 14 ; ^TMP("ECX-PRO EXC",$J) - Array for the exception message 15 ; ECXLNE - The number of the next line in the msg 16 ; ECXSTAT2 - Patient Station Number 17 ; ECXDATE - Delivery Date of Prosthesis 18 ; ECXTYPE - Type of Transaction work performed 19 ; ECXSRCE - Source of prosthesis 20 ; ECXHCPCS - CPT/HCPCS code for prosthesis 21 ; ECXRQST - Requesting Station 22 ; ECXRCST - Receiving Station 23 ; ECXPHCPC - PSAS HCPCS code; if 'unknown', then use CPT/HCPCS code 24 ; ECXNPPDC - NPPD code for repairs or new issues 25 ; Output (KILLed by NTEG) 26 ; ECXMISS - 1 indicates missing information 27 ; ECXGOOD - 0 indicates record should not be extracted 28 ; 29 N ECXGOOD,ECXMISS 30 S (ECXRCST,ECXRQST,ECXNPPDC)="",ECXGOOD=1,ECXSTAT2=$P(ECXN0,U,10) 31 I ECXSTAT2]"" D 32 .K ECXDIC 33 .S DA=ECXSTAT2,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99" 34 .D EN^DIQ1 S ECXSTAT2=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC 35 .S:(ECINST'=$E(ECXSTAT2,1,3)) ECXGOOD=0 ;*Screen for incorrect Station 36 ; 37 ;** Screen out records 38 S:($P(ECXN0,U,17)'="") ECXGOOD=0 ;*SHIP/DEL is not NULL 39 S:($P(ECXN0,U,26)'="") ECXGOOD=0 ;*PICKUP/DEL is not NULL 40 S:(+($P($G(^RMPR(660,ECXPIEN,"AM")),U,2))=1) ECXGOOD=0 ;*NO ADMIN CT=1 41 S:(($P(ECXN0,U,15))'="") ECXGOOD=0 ;*HISTORICAL DATA is not NULL 42 ; 43 S ECXDATE=$P(ECXN0,U,12),ECXTYPE=$P(ECXN0,U,4),ECXSRCE=$P(ECXN0,U,14) 44 S ECXHCPCS=$P($G(^ICPT(+$P(ECXN0,U,22),0)),U,1),ECXCMOD="" 45 S ECXHCPCS=$$CPT^ECXUTL3(ECXHCPCS,ECXCMOD) 46 ;get psas hcpcs code from file #661.1 47 S ECXPHCPC=$P($G(^RMPR(660,ECXPIEN,1)),U,4) D 48 .;get nppd code for repairs and new issues 10 characters in length. 49 .I "X5"[ECXTYPE S ECXNPPDC=$TR($$GET1^DIQ(661.1,ECXPHCPC_",",5)," ","_") 50 .I "IR"[ECXTYPE S ECXNPPDC=$TR($$GET1^DIQ(661.1,ECXPHCPC_",",6)," ","_") 51 .I +ECXPHCPC S ECXPHCPC=$E($P($G(^RMPR(661.1,ECXPHCPC,0)),U,1),1,5) 52 .I ECXPHCPC="UNKNOWN" S ECXPHCPC=$E(ECXHCPCS,1,5) 53 ; 54 ;* Get Requesting Station Number 55 I ECXFORM["-3" D 56 .S ECXRQST=$P(ECXNLB,U,1) 57 .I ECXRQST]"" D 58 ..S DA=ECXRQST,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99" 59 ..D EN^DIQ1 S ECXRQST=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC 60 S:(ECXFORM'["-3") ECXRQST="" 61 ; 62 ;* Screen out records 63 S:(+$P(ECXFORM,U,2)=13) ECXGOOD=0 ;*FORM REQUESTED ON = 13 64 ; 65 ;* Get Receiving Station Number 66 I ECXFORM["-3" D 67 .S ECXRCST=$P(ECXNLB,U,4) 68 .I ECXRCST]"" D 69 ..S DA=ECXRCST,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99" 70 ..D EN^DIQ1 S ECXRCST=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC 71 S:(ECXFORM'["-3") ECXRCST="" 72 ; 73 ;** Check for integrity and set up the problem variable if right DIV 74 I ECXGOOD D CHK 75 Q ECXGOOD 76 ; 77 CHK ;*Check variables 78 ; Input 79 ; Variables set in and Output from NTEG^ECXPRO1 80 ; Output 81 ; ^TMP("ECX-PRO EXC",$J, - Global of records with integrity problems 82 ; 83 S ECXMISS="" 84 I ECXSTAT2']"" S ECXMISS=ECXMISS_"1" 85 S ECXMISS=ECXMISS_U 86 I ECXDFN=0 S ECXMISS=ECXMISS_"1" 87 S ECXMISS=ECXMISS_U 88 ;I ECXSSN']"" S ECXMISS=ECXMISS_"1" 89 S ECXMISS=ECXMISS_U 90 ;I ECXNA=" " S ECXMISS=ECXMISS_"1" 91 S ECXMISS=ECXMISS_U 92 I ECXDATE']"" S ECXMISS=ECXMISS_"1" 93 S ECXMISS=ECXMISS_U 94 I ECXTYPE']"" S ECXMISS=ECXMISS_"1" 95 S ECXMISS=ECXMISS_U 96 I ECXSRCE']"" S ECXMISS=ECXMISS_"1" 97 S ECXMISS=ECXMISS_U 98 I ECXHCPCS']"" S ECXMISS=ECXMISS_"1" 99 S ECXMISS=ECXMISS_U 100 I ECXFORM["-3" D 101 .I ECXRQST']"" S ECXMISS=ECXMISS_"1" 102 S ECXMISS=ECXMISS_U 103 I ECXFORM']"" S ECXMISS=ECXMISS_"1" 104 S ECXMISS=ECXMISS_U 105 I ECXFORM["-3" D 106 .I ECXRCST']"" S ECXMISS=ECXMISS_"1" 107 I ECXMISS'="^^^^^^^^^^" D 108 .S ECXGOOD=0 109 .D ECXMISLN^ECXPRO2(ECXMISS,.ECXLNE,ECXPIEN) 110 Q 111 ; 112 PROSINFO(ECXDA,ECXLB,ECX0,ECXFORM) ;*Get Prosthetics Information 113 ; 114 ; Input 115 ; ECDA - The IEN for the Prosthetics record 116 ; ECX0 - The zero node of the Prosthetics record 117 ; ECXLB - The LB node of the Prosthetics record 118 ; ECXFORM - The Form Requested On (to determine Lab transactions) 119 ; 120 ; Output (to be KILLed by calling routine) 121 ; ECXCTAMT - The Cost of Transaction 122 ; ECXLLC - The Lab Labor Cost 123 ; ECXLMC - The Lab Material Cost 124 ; ECXGRPR - The AMIS Grouper number 125 ; ECXBILST - The Billing Status 126 ; ECXQTY - The Quantity 127 ; 128 S (ECXLLC,ECXLMC,ECXCTAMT)="",ECXBILST=$P($G(^RMPR(660,ECXDA,"AM")),U,3) 129 S ECXQTY=$P(ECX0,U,7) 130 S:(+ECXQTY=0) ECXQTY=1 131 ; 132 ;- Set Quantity field to 8 chars (right-justified & padded w/zeros) 133 S ECXQTY=$$RJ^XLFSTR(ECXQTY,8,0) 134 S ECXGRPR=$P($G(^RMPR(660,ECXDA,"AMS")),U,1),ECXCTAMT=$P(ECX0,U,16) 135 I ECXFORM["-3" D 136 .S ECXCTAMT=$P(ECXLB,U,9),ECXLLC=$P(ECXLB,U,7),ECXLMC=$P(ECXLB,U,8) 137 ; 138 ;- If Stock Issue or Inventory Issue, Cost of Transaction=0 139 I $P(ECXFORM,U,2)=11!($P(ECXFORM,U,2)=12) S ECXCTAMT=0 140 S:ECXCTAMT="" ECXCTAMT=0 S:ECXCTAMT>999999 ECXCTAMT=999999 141 S:ECXLLC="" ECXLLC=0 S:ECXLLC>999999 ECXLLC=999999 142 S:ECXLMC="" ECXLMC=0 S:ECXLMC>999999 ECXLMC=999999 143 ; 144 ;- Round to next dollar amount 145 I (ECXCTAMT#1)>.50 S ECXCTAMT=(ECXCTAMT+1)\1 146 I (ECXLLC#1)>.50 S ECXLLC=(ECXLLC+1)\1 147 I (ECXLMC#1)>.50 S ECXLMC=(ECXLMC+1)\1 148 Q 1 ECXPRO1 ;ALB/GTS - Prosthetics Extract for DSS (Continued) ; DEC 15, 2006 2 ;;3.0;DSS EXTRACTS;**9,11,13,15,21,24,33,37,39,100**;Dec 22, 1997;Build 2 3 ; 4 NTEG(ECXDFN,ECXLNE,ECXPIEN,ECXN0,ECXNLB,ECINST,ECXFORM) ;** Check for required fields 5 ; Input 6 ; ECXDFN - ien in file #2 7 ; ECXLNE - line number variable (passed by reference) 8 ; ECXPIEN - IEN for the Prosthetics record 9 ; ECXN0 - zero node of the Prosthetics record 10 ; ECXNLB - LB node of the Prosthetics record 11 ; ECINST - station number being extracted 12 ; ECXFORM - Form Requested On 13 ; Output (to be KILLed by calling routine) 14 ; ^TMP("ECX-PRO EXC",$J) - Array for the exception message 15 ; ECXLNE - The number of the next line in the msg 16 ; ECXSTAT2 - Patient Station Number 17 ; ECXDATE - Delivery Date of Prosthesis 18 ; ECXTYPE - Type of Transaction work performed 19 ; ECXSRCE - Source of prosthesis 20 ; ECXHCPCS - CPT/HCPCS code for prosthesis 21 ; ECXRQST - Requesting Station 22 ; ECXRCST - Receiving Station 23 ; ECXPHCPC - PSAS HCPCS code; if 'unknown', then use CPT/HCPCS code 24 ; Output (KILLed by NTEG) 25 ; ECXMISS - 1 indicates missing information 26 ; ECXGOOD - 0 indicates record should not be extracted 27 ; 28 N ECXGOOD,ECXMISS 29 S (ECXRCST,ECXRQST)="",ECXGOOD=1,ECXSTAT2=$P(ECXN0,U,10) 30 I ECXSTAT2]"" D 31 .K ECXDIC 32 .S DA=ECXSTAT2,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99" 33 .D EN^DIQ1 S ECXSTAT2=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC 34 .S:(ECINST'=$E(ECXSTAT2,1,3)) ECXGOOD=0 ;*Screen for incorrect Station 35 ; 36 ;** Screen out records 37 S:($P(ECXN0,U,17)'="") ECXGOOD=0 ;*SHIP/DEL is not NULL 38 S:($P(ECXN0,U,26)'="") ECXGOOD=0 ;*PICKUP/DEL is not NULL 39 S:(+($P($G(^RMPR(660,ECXPIEN,"AM")),U,2))=1) ECXGOOD=0 ;*NO ADMIN CT=1 40 S:(($P(ECXN0,U,15))'="") ECXGOOD=0 ;*HISTORICAL DATA is not NULL 41 ; 42 S ECXDATE=$P(ECXN0,U,12),ECXTYPE=$P(ECXN0,U,4),ECXSRCE=$P(ECXN0,U,14) 43 S ECXHCPCS=$P($G(^ICPT(+$P(ECXN0,U,22),0)),U,1),ECXCMOD="" 44 S ECXHCPCS=$$CPT^ECXUTL3(ECXHCPCS,ECXCMOD) 45 ;get psas hcpcs code from file #661.1 46 S ECXPHCPC=$P($G(^RMPR(660,ECXPIEN,1)),U,4) D 47 .;I +ECXPHCPC S ECXPHCPC=$P($G(^RMPR(661.1,ECXPHCPC,0)),U,1) 48 .I +ECXPHCPC S ECXPHCPC=$E($P($G(^RMPR(661.1,ECXPHCPC,0)),U,1),1,5) 49 .I ECXPHCPC="UNKNOWN" S ECXPHCPC=$E(ECXHCPCS,1,5) 50 ; 51 ;* Get Requesting Station Number 52 I ECXFORM["-3" D 53 .S ECXRQST=$P(ECXNLB,U,1) 54 .I ECXRQST]"" D 55 ..S DA=ECXRQST,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99" 56 ..D EN^DIQ1 S ECXRQST=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC 57 S:(ECXFORM'["-3") ECXRQST="" 58 ; 59 ;* Screen out records 60 S:(+$P(ECXFORM,U,2)=13) ECXGOOD=0 ;*FORM REQUESTED ON = 13 61 ; 62 ;* Get Receiving Station Number 63 I ECXFORM["-3" D 64 .S ECXRCST=$P(ECXNLB,U,4) 65 .I ECXRCST]"" D 66 ..S DA=ECXRCST,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99" 67 ..D EN^DIQ1 S ECXRCST=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC 68 S:(ECXFORM'["-3") ECXRCST="" 69 ; 70 ;** Check for integrity and set up the problem variable if right DIV 71 I ECXGOOD D CHK 72 Q ECXGOOD 73 ; 74 CHK ;*Check variables 75 ; Input 76 ; Variables set in and Output from NTEG^ECXPRO1 77 ; Output 78 ; ^TMP("ECX-PRO EXC",$J, - Global of records with integrity problems 79 ; 80 S ECXMISS="" 81 I ECXSTAT2']"" S ECXMISS=ECXMISS_"1" 82 S ECXMISS=ECXMISS_U 83 I ECXDFN=0 S ECXMISS=ECXMISS_"1" 84 S ECXMISS=ECXMISS_U 85 ;I ECXSSN']"" S ECXMISS=ECXMISS_"1" 86 S ECXMISS=ECXMISS_U 87 ;I ECXNA=" " S ECXMISS=ECXMISS_"1" 88 S ECXMISS=ECXMISS_U 89 I ECXDATE']"" S ECXMISS=ECXMISS_"1" 90 S ECXMISS=ECXMISS_U 91 I ECXTYPE']"" S ECXMISS=ECXMISS_"1" 92 S ECXMISS=ECXMISS_U 93 I ECXSRCE']"" S ECXMISS=ECXMISS_"1" 94 S ECXMISS=ECXMISS_U 95 I ECXHCPCS']"" S ECXMISS=ECXMISS_"1" 96 S ECXMISS=ECXMISS_U 97 I ECXFORM["-3" D 98 .I ECXRQST']"" S ECXMISS=ECXMISS_"1" 99 S ECXMISS=ECXMISS_U 100 I ECXFORM']"" S ECXMISS=ECXMISS_"1" 101 S ECXMISS=ECXMISS_U 102 I ECXFORM["-3" D 103 .I ECXRCST']"" S ECXMISS=ECXMISS_"1" 104 I ECXMISS'="^^^^^^^^^^" D 105 .S ECXGOOD=0 106 .D ECXMISLN^ECXPRO2(ECXMISS,.ECXLNE,ECXPIEN) 107 Q 108 ; 109 PROSINFO(ECXDA,ECXLB,ECX0,ECXFORM) ;*Get Prosthetics Information 110 ; 111 ; Input 112 ; ECDA - The IEN for the Prosthetics record 113 ; ECX0 - The zero node of the Prosthetics record 114 ; ECXLB - The LB node of the Prosthetics record 115 ; ECXFORM - The Form Requested On (to determine Lab transactions) 116 ; 117 ; Output (to be KILLed by calling routine) 118 ; ECXCTAMT - The Cost of Transaction 119 ; ECXLLC - The Lab Labor Cost 120 ; ECXLMC - The Lab Material Cost 121 ; ECXGRPR - The AMIS Grouper number 122 ; ECXBILST - The Billing Status 123 ; ECXQTY - The Quantity 124 ; 125 S (ECXLLC,ECXLMC,ECXCTAMT)="",ECXBILST=$P($G(^RMPR(660,ECXDA,"AM")),U,3) 126 S ECXQTY=$P(ECX0,U,7) 127 S:(+ECXQTY=0) ECXQTY=1 128 ; 129 ;- Set Quantity field to 8 chars (right-justified & padded w/zeros) 130 S ECXQTY=$$RJ^XLFSTR(ECXQTY,8,0) 131 S ECXGRPR=$P($G(^RMPR(660,ECXDA,"AMS")),U,1),ECXCTAMT=$P(ECX0,U,16) 132 I ECXFORM["-3" D 133 .S ECXCTAMT=$P(ECXLB,U,9),ECXLLC=$P(ECXLB,U,7),ECXLMC=$P(ECXLB,U,8) 134 ; 135 ;- If Stock Issue or Inventory Issue, Cost of Transaction=0 136 I $P(ECXFORM,U,2)=11!($P(ECXFORM,U,2)=12) S ECXCTAMT=0 137 S:ECXCTAMT="" ECXCTAMT=0 S:ECXCTAMT>999999 ECXCTAMT=999999 138 S:ECXLLC="" ECXLLC=0 S:ECXLLC>999999 ECXLLC=999999 139 S:ECXLMC="" ECXLMC=0 S:ECXLMC>999999 ECXLMC=999999 140 ; 141 ;- Round to next dollar amount 142 I (ECXCTAMT#1)>.50 S ECXCTAMT=(ECXCTAMT+1)\1 143 I (ECXLLC#1)>.50 S ECXLLC=(ECXLLC+1)\1 144 I (ECXLMC#1)>.50 S ECXLMC=(ECXLMC+1)\1 145 Q -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXPURG.m
r613 r623 1 ECXPURG ;BIR/CML-Driver for Purge of DSS Data from Local Extract & Holding Files ; 4/17/07 2:35pm 2 ;;3.0;DSS EXTRACTS;**9,24,33,35,49,102**;Dec 22, 1997;Build 17 3 EN ;entry point from option 4 W @IOF,!!,"This option will allow you to purge:" 5 W !,"1. individual or a range of DSS extracts, or" 6 W !,"2. data that resides in the ""holding files"" for the IVP and UDP extracts." 7 W !,"3. data that resides in the ""holding file"" for the VBECS extract" 8 W !!,"Care must be taken for several reasons:" 9 W !!,"- You can purge ANY existing extract. This includes transmitted and non-" 10 W !," transmitted extracts as well as extracts that did not run to completion" 11 W !," due to errors or system problems." 12 W !,"- Choosing a range of extracts (or a broad date range for the ""holding" 13 W !," files"") could mean an excessively large number of records and be very" 14 W !," CPU intensive. Please be sure to queue this purge for off-hours and" 15 W !," limit the number of extracts to be purged per a single queued session." 16 W !,"- The IVP, UDP and VBECS ""holding"" files are intermediate files that" 17 W !," are populated ""realtime"" by inpatient pharmacy and VBECS activity. These" 18 W !," files are then used to generate the IVP, UDP and VBECS extracts and CANNOT be" 19 W !," recreated. Once they are purged for a date range, extracts can no longer be" 20 W !," generated for that time period." 21 ; 22 K DIR W ! 23 S DIR(0)="SAM^E:Extract Files;I:IVP Holding File;U:UDP Holding File;V:VBECS Holding File" 24 S DIR("A")="Purge (E)xtract files, (I)VP data, (U)DP data or (V)BECS data? " 25 D ^DIR K DIR G:$D(DIRUT) QUIT S ECY=Y 26 I ECY="E" D ^ECXPURG1 I $D(ECLOC) S ZTSAVE("ECLOC(")="",ZTIO="",ZTRTN="PUR1^ECXPURG",ZTDESC="DSS - Purge of Extract Files" D QUE 27 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 28 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 29 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 30 QUIT ; 31 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 32 K ECXDIV 33 S:$D(ZTQUEUED) ZTREQ="@" 34 Q 35 QUE W $C(7),$C(7),!!?3,"<<This purge should be queued to run during non-peak hours.>>",! 36 D ^%ZTLOAD 37 I $D(ZTSK) W !,"Request queued as Task #",ZTSK,".",! 38 Q 39 ; 40 PUR1 ; entry point for queued purge job of extract files 41 S ECDA=0 F S ECDA=$O(ECLOC(ECDA)) Q:'ECDA D 42 .S ECFILE=^ECX(727,ECDA,"FILE"),ECJ=0 43 .I ECFILE=727.827 D 44 ..S DA(1)=1 45 ..S DA=$O(^ECX(728,DA(1),"CBOC","B",ECDA,0)) 46 ..S DIK="^ECX(728,"_DA(1)_","_"""CBOC"""_"," 47 ..I DA'="" D ^DIK K DIK,DA 48 .F S ECJ=$O(^ECX(ECFILE,"AC",ECDA,ECJ)) Q:'ECJ D 49 ..S DIK="^ECX("_ECFILE_",",DA=ECJ D ^DIK K DIK,DA 50 .I ECFILE=727.816 S ECFILE=727.818,ECJ=0 D 51 ..F S ECJ=$O(^ECX(ECFILE,"AC",ECDA,ECJ)) Q:'ECJ D 52 ...S DIK="^ECX("_ECFILE_",",DA=ECJ D ^DIK K DIK,DA 53 .S ^ECX(727,ECDA,"PURG")=DT 54 D QUIT 55 Q 56 ; 57 PUR2 ; entry point for queued purge job of IVP holding file (#728.113) 58 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 59 .S ECOR=0 F S ECOR=$O(^ECX(728.113,"A",ECDT,ECPT,ECOR)) Q:'ECOR D 60 ..S ECREC=0 F S ECREC=$O(^ECX(728.113,"A",ECDT,ECPT,ECOR,ECREC)) Q:'ECREC D 61 ...S DIK="^ECX(728.113,",DA=ECREC D ^DIK K DIK,DA 62 D QUIT 63 Q 64 ; 65 PUR3 ; entry point for queued purge job of UDP holding file (#728.904) 66 F ECDT=ECBDT-1:0 S ECDT=$O(^ECX(728.904,"A",ECDT)) Q:'ECDT Q:ECDT>ECEDT D 67 .S ECREC=0 F S ECREC=$O(^ECX(728.904,"A",ECDT,ECREC)) Q:'ECREC D 68 ..S DIK="^ECX(728.904,",DA=ECREC D ^DIK K DIK,DA 69 D QUIT 70 Q 71 ; 72 PUR4 ; entry point for queued purge job of VBECS holding file (#6002.03) 73 N ECDT,ECREC,DIK,DA 74 S ECDT=ECBDT-1,ECEDT=ECEDT+.9 75 F S ECDT=$O(^VBEC(6002.03,"C",ECDT)) Q:'ECDT!(ECDT>ECEDT) D 76 .S ECREC=0 F S ECREC=$O(^VBEC(6002.03,"C",ECDT,ECREC)) Q:'ECREC D 77 ..S DIK="^VBEC(6002.03,",DA=ECREC D ^DIK K DIK,DA 78 Q 1 ECXPURG ;BIR/CML-Driver for Purge of DSS Data from Local Extract & Holding Files ; [ 12/03/96 5:19 PM ] 2 ;;3.0;DSS EXTRACTS;**9,24,33,35,49**;Dec 22, 1997 3 EN ;entry point from option 4 W @IOF,!!,"This option will allow you to purge:" 5 W !,"1. individual or a range of DSS extracts, or" 6 W !,"2. data that resides in the ""holding files"" for the IVP and UDP extracts." 7 W !!,"Care must be taken for several reasons:" 8 W !!,"- You can purge ANY existing extract. This includes transmitted and non-" 9 W !," transmitted extracts as well as extracts that did not run to completion" 10 W !," due to errors or system problems." 11 W !,"- Choosing a range of extracts (or a broad date range for the ""holding" 12 W !," files"") could mean an excessively large number of records and be very" 13 W !," CPU intensive. Please be sure to queue this purge for off-hours and" 14 W !," limit the number of extracts to be purged per a single queued session." 15 W !,"- The IVP and UDP ""holding"" files are intermediate files that are" 16 W !," populated ""realtime"" by inpatient pharmacy activity. These files are" 17 W !," then used to generate the IVP and UDP extracts and CANNOT be recreated." 18 W !," Once they are purged for a date range, extracts can no longer be" 19 W !," generated for that time period." 20 ; 21 K DIR W ! 22 S DIR(0)="SAM^E:Extract Files;I:IVP Holding File;U:UDP Holding File" 23 S DIR("A")="Purge (E)xtract files, (I)VP data, or (U)DP data? " 24 D ^DIR K DIR G:$D(DIRUT) QUIT S ECY=Y 25 I ECY="E" D ^ECXPURG1 I $D(ECLOC) S ZTSAVE("ECLOC(")="",ZTIO="",ZTRTN="PUR1^ECXPURG",ZTDESC="DSS - Purge of Extract Files" D QUE 26 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 27 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 28 QUIT ; 29 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 30 K ECXDIV 31 S:$D(ZTQUEUED) ZTREQ="@" 32 Q 33 QUE W $C(7),$C(7),!!?3,"<<This purge should be queued to run during non-peak hours.>>",! 34 D ^%ZTLOAD 35 I $D(ZTSK) W !,"Request queued as Task #",ZTSK,".",! 36 Q 37 ; 38 PUR1 ; entry point for queued purge job of extract files 39 S ECDA=0 F S ECDA=$O(ECLOC(ECDA)) Q:'ECDA D 40 .S ECFILE=^ECX(727,ECDA,"FILE"),ECJ=0 41 .I ECFILE=727.827 D 42 ..S DA(1)=1 43 ..S DA=$O(^ECX(728,DA(1),"CBOC","B",ECDA,0)) 44 ..S DIK="^ECX(728,"_DA(1)_","_"""CBOC"""_"," 45 ..I DA'="" D ^DIK K DIK,DA 46 .F S ECJ=$O(^ECX(ECFILE,"AC",ECDA,ECJ)) Q:'ECJ D 47 ..S DIK="^ECX("_ECFILE_",",DA=ECJ D ^DIK K DIK,DA 48 .I ECFILE=727.816 S ECFILE=727.818,ECJ=0 D 49 ..F S ECJ=$O(^ECX(ECFILE,"AC",ECDA,ECJ)) Q:'ECJ D 50 ...S DIK="^ECX("_ECFILE_",",DA=ECJ D ^DIK K DIK,DA 51 .S ^ECX(727,ECDA,"PURG")=DT 52 D QUIT 53 Q 54 ; 55 PUR2 ; entry point for queued purge job of IVP holding file (#728.113) 56 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 57 .S ECOR=0 F S ECOR=$O(^ECX(728.113,"A",ECDT,ECPT,ECOR)) Q:'ECOR D 58 ..S ECREC=0 F S ECREC=$O(^ECX(728.113,"A",ECDT,ECPT,ECOR,ECREC)) Q:'ECREC D 59 ...S DIK="^ECX(728.113,",DA=ECREC D ^DIK K DIK,DA 60 D QUIT 61 Q 62 ; 63 PUR3 ; entry point for queued purge job of UDP holding file (#728.904) 64 F ECDT=ECBDT-1:0 S ECDT=$O(^ECX(728.904,"A",ECDT)) Q:'ECDT Q:ECDT>ECEDT D 65 .S ECREC=0 F S ECREC=$O(^ECX(728.904,"A",ECDT,ECREC)) Q:'ECREC D 66 ..S DIK="^ECX(728.904,",DA=ECREC D ^DIK K DIK,DA 67 D QUIT 68 Q -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXPURG1.m
r613 r623 1 ECXPURG1 ;BIR/CML-Purge of DSS Extract Files (CONTINUED) ; 5/27/08 9:26am 2 ;;3.0;DSS EXTRACTS;**2,9,8,24,49,102**;Dec 22, 1997;Build 17 3 GET ;compile list of purgable extracts 4 K HI,LO,ECBDT,ECEDT,ECLOC,^TMP("ECXPURG",$J) 5 S QFLG=1 W !!,"...one moment please" 6 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 7 .S ^TMP("ECXPURG",$J,$P(EC,U,3),ECEX)="",ECLOC(ECEX)=$P(EC,U,3)_U_$P(EC,U,4,5) 8 I '$D(^TMP("ECXPURG",$J)) W !!,"There are no extracts that can be purged at this time." G DONE 9 ASK1 ;ask for print 10 W ! 11 K DIR S DIR(0)="Y",DIR("A")="Do you want to print a list of extracts that can be purged",DIR("B")="NO" 12 D ^DIR K DIR I $D(DIRUT) K ECLOC G DONE 13 G:'Y ASK2 14 W !!,"The right margin for this report is 80.",!! 15 K ZTSAVE S ZTSAVE("^TMP(""ECXPURG"",$J,")="" 16 D EN^XUTMDEVQ("PRT^ECXPURG1","DSS - Print Purgable Extracts",.ZTSAVE) I 'POP G ASK2 17 W !,"NO DEVICE SELECTED OR REPORT PRINTED!!" 18 ASK2 ;ask for extract range 19 ; 20 ;** Check divisions for purging 21 N ECCHK,ECTMP 22 S ECCHK=$$DIV4^XUSER(.ECTMP,DUZ) 23 I 'ECCHK DO 24 .W !,"You do not have any divisions defined in your user set up and can not purge." 25 .S DIR(0)="FAO^1:1",DIR("A")="Hit Return to continue." D ^DIR K DIR,X,Y 26 .K ECLOC 27 ; 28 I 'ECCHK G DONE ;** (essentially) QUIT out of middle 29 ; 30 W !,"You will not be able to select an extract that is not from your division.",! 31 S LO=$O(ECLOC(0)),HI=$O(ECLOC(" "),-1) 32 S DIR(0)="L^"_LO_":"_HI_"",DIR("A")="Select extracts to be purged" 33 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)." 34 W ! D ^DIR K DIR I $D(DIRUT) K ECLOC G DONE 35 S JJ=0,Y=","_Y F S JJ=$O(ECLOC(JJ)) Q:'JJ S JZ=","_JJ_"," I Y'[JZ K ECLOC(JJ) 36 D CBOCCHK(.ECLOC) I '$D(ECLOC) G GET 37 D DIVCHK(.ECLOC,.ECTMP) 38 I '$D(ECLOC) W !!,"You have not chosen a valid extract number. Try again." G GET 39 ASK3 W !!,"I will purge the following extract(s):" 40 S JJ=0 F S JJ=$O(ECLOC(JJ)) Q:'JJ D 41 .W !?5,"#",JJ," - ",$P(ECLOC(JJ),U) 42 .W ?47,$TR($$FMTE^XLFDT($P(ECLOC(JJ),U,2),"5DF")," ","0")," to ",$TR($$FMTE^XLFDT($P(ECLOC(JJ),U,3),"5DF")," ","0") 43 W !! K DIR S DIR(0)="Y",DIR("A")="Is this OK",DIR("B")="NO" 44 S DIR("?",1)=" Enter:" 45 S DIR("?",2)=" ""YES"" if you agree with this list and would like to proceed," 46 S DIR("?",3)=" ""NO"" if you would like to make a different selection, or" 47 S DIR("?")=" ""^"" to exit option." 48 D ^DIR K DIR I $D(DIRUT) K ECLOC G DONE 49 I 'Y G GET 50 ; at this point, the local array ECLOC( is passed back to ^ECXPURG 51 G DONE 52 QUIT ; 53 I $E(IOST)="C"&('QFLG) S DIR(0)="E" D D ^DIR K DIR 54 .S SS=22-$Y F JJ=1:1:SS W ! 55 W:$E(IOST)'="C" @IOF D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" 56 DONE K ^TMP("ECXPURG",$J),ZTSK Q 57 PRT ;print list of extracts 58 S (PG,QFLG)=0,$P(LN,"-",81)="" D NOW^%DTC S Y=$E(%,1,12) X ^DD("DD") S HDT=Y D HDR 59 S ECTYP="" F S ECTYP=$O(^TMP("ECXPURG",$J,ECTYP)) Q:ECTYP="" Q:QFLG D:$Y+4>IOSL HDR Q:QFLG W !!,ECTYP D 60 .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 61 ..S ECDT=$$FMTE^XLFDT($P(EC,U,2),"D") 62 ..S ECFR=$TR($$FMTE^XLFDT($P(EC,U,4),"5DF")," ","0") 63 ..S ECTO=$TR($$FMTE^XLFDT($P(EC,U,5),"5DF")," ","0") 64 ..S ECRC=$P(EC,U,6) S:ECRC="" ECRC="Incomplete" 65 ..S ECTRN=$$FMTE^XLFDT($G(^ECX(727,ECEX,"TR")),"D") 66 ..S ECXDIV=$P($G(^ECX(727,ECEX,"DIV")),U,1) I ECXDIV D 67 ...K ECXDIC S DA=ECXDIV,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99" 68 ...D EN^DIQ1 S ECXDIV=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC 69 ..D:$Y+3>IOSL HDR Q:QFLG 70 ..W !?1,ECEX,?11,ECDT,?25,ECFR,"-",ECTO,?48,$J(ECRC,9),?60,ECTRN,?75,ECXDIV 71 G QUIT 72 HDR ;HEADER 73 I $E(IOST)="C" S SS=22-$Y F JJ=1:1:SS W ! 74 I $E(IOST)="C",PG>0 S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q 75 S PG=PG+1 W:$Y!($E(IOST)="C") @IOF W !,"PURGABLE EXTRACTS",?72,"Page: ",PG,!,"Printed on ",HDT,! 76 W !,"FEEDER SYS",?12,"EXTRACT,",!,"EXTRACT #",?12,"DATE",?33,"FROM-TO",?48,"RECORD CNT",?60,"TRANSMIT DATE",?75,"DIV",!,LN 77 Q 78 DATES ;ask for date range for purge of holding files 79 K HI,LO,ECBDT,ECEDT 80 I ECY="I" D 81 .I '$O(^ECX(728.113,0)) W !!,"You have no data in the IVP holding file (file #728.113) to purge." Q 82 .S LO=$O(^ECX(728.113,"A",0)),HI=$O(^ECX(728.113,"A"," "),-1) 83 I ECY="U" D 84 .I '$O(^ECX(728.904,0)) W !!,"You have no data in the UDP holding file (file #728.904) to purge." Q 85 .S LO=$O(^ECX(728.904,"A",0)),HI=$O(^ECX(728.904,"A"," "),-1) 86 I ECY="V" D 87 .I '$O(^VBEC(6002.03,0)) W !!,"You have no data in the VBECS holding file (file #6002.03) to purge." Q 88 .S LO=$O(^VBEC(6002.03,"C",0)),HI=$O(^VBEC(6002.03,"C"," "),-1) 89 Q:$G(LO)="" 90 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"),">." 91 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 92 S ECBDT=+Y 93 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 94 S ECEDT=+Y 95 ASK4 ; ask to confirm date range 96 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"),">." 97 W $C(7),$C(7),!!?3,"** REMEMBER - Once this data is purged it CANNOT be recreated. **" 98 W !! K DIR S DIR(0)="Y",DIR("A")="Is this OK",DIR("B")="NO" 99 S DIR("?",1)=" Enter:" 100 S DIR("?",2)=" ""YES"" if you agree with this date range and wish to proceed," 101 S DIR("?",3)=" ""NO"" if you would like to make a different selection, or" 102 S DIR("?")=" ""^"" to exit option." 103 D ^DIR K DIR I $D(DIRUT) K ECBDT,ECEDT Q 104 I 'Y G DATES 105 ; at this point, ECBDT and ECEDT are passed back to ^ECXPURG 106 Q 107 ; 108 DIVCHK(ECLOC,ECTMP) ;**Remove extracts from ECLOC that are for user's div. 109 N ECLPDA 110 S ECLPDA=0 111 F S ECLPDA=$O(ECLOC(ECLPDA)) Q:(+ECLPDA=0) DO 112 .I '$D(ECTMP($P(^ECX(727,ECLPDA,"DIV"),U,1))) KILL ECLOC(ECLPDA) 113 Q 114 CBOCCHK(ECLOC) ;**Check that CBOC report has been viewed prior to purging 115 N LOOPDA,YYYMMDD 116 S LOOPDA=0 117 F S LOOPDA=$O(ECLOC(LOOPDA)) Q:(+LOOPDA=0) D 118 .I ^ECX(727,LOOPDA,"HEAD")="CLI" D 119 ..S DA(1)=1 120 ..S YYYMMDD=$P(^ECX(727,LOOPDA,0),U,4) 121 ..I YYYMMDD>3030930 I '$D(^ECX(728,DA(1),"CBOC","B",LOOPDA)) D 122 ...K DIR S DIR(0)="Y",DIR("A")="The CBOC Activity Report has not been viewed. Purge anyway",DIR("B")="NO" 123 ...D ^DIR K DIR I 'Y K ECLOC(LOOPDA) 124 Q 1 ECXPURG1 ;BIR/CML-Purge of DSS Extract Files (CONTINUED) ; [ 12/05/96 11:58 AM ] 2 ;;3.0;DSS EXTRACTS;**2,9,8,24,49**;Dec 22, 1997 3 GET ;compile list of purgable extracts 4 K HI,LO,ECBDT,ECEDT,ECLOC,^TMP("ECXPURG",$J) 5 S QFLG=1 W !!,"...one moment please" 6 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 7 .S ^TMP("ECXPURG",$J,$P(EC,U,3),ECEX)="",ECLOC(ECEX)=$P(EC,U,3)_U_$P(EC,U,4,5) 8 I '$D(^TMP("ECXPURG",$J)) W !!,"There are no extracts that can be purged at this time." G DONE 9 ASK1 ;ask for print 10 W ! 11 K DIR S DIR(0)="Y",DIR("A")="Do you want to print a list of extracts that can be purged",DIR("B")="NO" 12 D ^DIR K DIR I $D(DIRUT) K ECLOC G DONE 13 G:'Y ASK2 14 W !!,"The right margin for this report is 80.",!! 15 K ZTSAVE S ZTSAVE("^TMP(""ECXPURG"",$J,")="" 16 D EN^XUTMDEVQ("PRT^ECXPURG1","DSS - Print Purgable Extracts",.ZTSAVE) I 'POP G ASK2 17 W !,"NO DEVICE SELECTED OR REPORT PRINTED!!" 18 ASK2 ;ask for extract range 19 ; 20 ;** Check divisions for purging 21 N ECCHK,ECTMP 22 S ECCHK=$$DIV4^XUSER(.ECTMP,DUZ) 23 I 'ECCHK DO 24 .W !,"You do not have any divisions defined in your user set up and can not purge." 25 .S DIR(0)="FAO^1:1",DIR("A")="Hit Return to continue." D ^DIR K DIR,X,Y 26 .K ECLOC 27 ; 28 I 'ECCHK G DONE ;** (essentially) QUIT out of middle 29 ; 30 W !,"You will not be able to select an extract that is not from your division.",! 31 S LO=$O(ECLOC(0)),HI=$O(ECLOC(" "),-1) 32 S DIR(0)="L^"_LO_":"_HI_"",DIR("A")="Select extracts to be purged" 33 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)." 34 W ! D ^DIR K DIR I $D(DIRUT) K ECLOC G DONE 35 S JJ=0,Y=","_Y F S JJ=$O(ECLOC(JJ)) Q:'JJ S JZ=","_JJ_"," I Y'[JZ K ECLOC(JJ) 36 D CBOCCHK(.ECLOC) I '$D(ECLOC) G GET 37 D DIVCHK(.ECLOC,.ECTMP) 38 I '$D(ECLOC) W !!,"You have not chosen a valid extract number. Try again." G GET 39 ASK3 W !!,"I will purge the following extract(s):" 40 S JJ=0 F S JJ=$O(ECLOC(JJ)) Q:'JJ D 41 .W !?5,"#",JJ," - ",$P(ECLOC(JJ),U) 42 .W ?47,$TR($$FMTE^XLFDT($P(ECLOC(JJ),U,2),"5DF")," ","0")," to ",$TR($$FMTE^XLFDT($P(ECLOC(JJ),U,3),"5DF")," ","0") 43 W !! K DIR S DIR(0)="Y",DIR("A")="Is this OK",DIR("B")="NO" 44 S DIR("?",1)=" Enter:" 45 S DIR("?",2)=" ""YES"" if you agree with this list and would like to proceed," 46 S DIR("?",3)=" ""NO"" if you would like to make a different selection, or" 47 S DIR("?")=" ""^"" to exit option." 48 D ^DIR K DIR I $D(DIRUT) K ECLOC G DONE 49 I 'Y G GET 50 ; at this point, the local array ECLOC( is passed back to ^ECXPURG 51 G DONE 52 QUIT ; 53 I $E(IOST)="C"&('QFLG) S DIR(0)="E" D D ^DIR K DIR 54 .S SS=22-$Y F JJ=1:1:SS W ! 55 W:$E(IOST)'="C" @IOF D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" 56 DONE K ^TMP("ECXPURG",$J),ZTSK Q 57 PRT ;print list of extracts 58 S (PG,QFLG)=0,$P(LN,"-",81)="" D NOW^%DTC S Y=$E(%,1,12) X ^DD("DD") S HDT=Y D HDR 59 S ECTYP="" F S ECTYP=$O(^TMP("ECXPURG",$J,ECTYP)) Q:ECTYP="" Q:QFLG D:$Y+4>IOSL HDR Q:QFLG W !!,ECTYP D 60 .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 61 ..S ECDT=$$FMTE^XLFDT($P(EC,U,2),"D") 62 ..S ECFR=$TR($$FMTE^XLFDT($P(EC,U,4),"5DF")," ","0") 63 ..S ECTO=$TR($$FMTE^XLFDT($P(EC,U,5),"5DF")," ","0") 64 ..S ECRC=$P(EC,U,6) S:ECRC="" ECRC="Incomplete" 65 ..S ECTRN=$$FMTE^XLFDT($G(^ECX(727,ECEX,"TR")),"D") 66 ..S ECXDIV=$P($G(^ECX(727,ECEX,"DIV")),U,1) I ECXDIV D 67 ...K ECXDIC S DA=ECXDIV,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99" 68 ...D EN^DIQ1 S ECXDIV=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC 69 ..D:$Y+3>IOSL HDR Q:QFLG 70 ..W !?1,ECEX,?11,ECDT,?25,ECFR,"-",ECTO,?48,$J(ECRC,9),?60,ECTRN,?75,ECXDIV 71 G QUIT 72 HDR ;HEADER 73 I $E(IOST)="C" S SS=22-$Y F JJ=1:1:SS W ! 74 I $E(IOST)="C",PG>0 S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q 75 S PG=PG+1 W:$Y!($E(IOST)="C") @IOF W !,"PURGABLE EXTRACTS",?72,"Page: ",PG,!,"Printed on ",HDT,! 76 W !,"FEEDER SYS",?12,"EXTRACT,",!,"EXTRACT #",?12,"DATE",?33,"FROM-TO",?48,"RECORD CNT",?60,"TRANSMIT DATE",?75,"DIV",!,LN 77 Q 78 DATES ;ask for date range for purge of holding files 79 K HI,LO,ECBDT,ECEDT 80 I ECY="I" D 81 .I '$O(^ECX(728.113,0)) W !!,"You have no data in the IVP holding file (file #728.113) to purge." Q 82 .S LO=$O(^ECX(728.113,"A",0)),HI=$O(^ECX(728.113,"A"," "),-1) 83 I ECY="U" D 84 .I '$O(^ECX(728.904,0)) W !!,"You have no data in the UDP holding file (file #728.904) to purge." Q 85 .S LO=$O(^ECX(728.904,"A",0)),HI=$O(^ECX(728.904,"A"," "),-1) 86 Q:$G(LO)="" 87 W @IOF,!!,"This file currently holds ",$S(ECY="I":"IVP",1:"UDP")," data from <",$$FMTE^XLFDT(LO,"D"),"> to <",$$FMTE^XLFDT(HI,"D"),">." 88 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 89 S ECBDT=+Y 90 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 91 S ECEDT=+Y 92 ASK4 ; ask to confirm date range 93 W !!,"I will purge the ",$S(ECY="I":"IVP",1:"UDP")," holding file from <",$$FMTE^XLFDT(ECBDT,"D"),"> to <",$$FMTE^XLFDT(ECEDT,"D"),">." 94 W $C(7),$C(7),!!?3,"** REMEMBER - Once this data is purged it CANNOT be recreated. **" 95 W !! K DIR S DIR(0)="Y",DIR("A")="Is this OK",DIR("B")="NO" 96 S DIR("?",1)=" Enter:" 97 S DIR("?",2)=" ""YES"" if you agree with this date range and wish to proceed," 98 S DIR("?",3)=" ""NO"" if you would like to make a different selection, or" 99 S DIR("?")=" ""^"" to exit option." 100 D ^DIR K DIR I $D(DIRUT) K ECBDT,ECEDT Q 101 I 'Y G DATES 102 ; at this point, ECBDT and ECEDT are passed back to ^ECXPURG 103 Q 104 ; 105 DIVCHK(ECLOC,ECTMP) ;**Remove extracts from ECLOC that are for user's div. 106 N ECLPDA 107 S ECLPDA=0 108 F S ECLPDA=$O(ECLOC(ECLPDA)) Q:(+ECLPDA=0) DO 109 .I '$D(ECTMP($P(^ECX(727,ECLPDA,"DIV"),U,1))) KILL ECLOC(ECLPDA) 110 Q 111 CBOCCHK(ECLOC) ;**Check that CBOC report has been viewed prior to purging 112 N LOOPDA,YYYMMDD 113 S LOOPDA=0 114 F S LOOPDA=$O(ECLOC(LOOPDA)) Q:(+LOOPDA=0) D 115 .I ^ECX(727,LOOPDA,"HEAD")="CLI" D 116 ..S DA(1)=1 117 ..S YYYMMDD=$P(^ECX(727,LOOPDA,0),U,4) 118 ..I YYYMMDD>3030930 I '$D(^ECX(728,DA(1),"CBOC","B",LOOPDA)) D 119 ...K DIR S DIR(0)="Y",DIR("A")="The CBOC Activity Report has not been viewed. Purge anyway",DIR("B")="NO" 120 ...D ^DIR K DIR I 'Y K ECLOC(LOOPDA) 121 Q -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXQSR.m
r613 r623 1 ECXQSR ;ALB/JAP,BIR/PTD-DSS QUASAR Extract ; 7/31/07 11:19pm 2 ;;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 3 BEG ;entry point from option 4 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 5 I '$D(^ACK(509850.8,1,"DSS")) W !,"Linkage has not been established between QUASAR and the DSS UNIT file (#724).",!! Q 6 I '$O(^ACK(509850.6,0)) W !,"There is no data in the A&SP CLINIC VISIT file (#509850.6).",!! Q 7 D SETUP I ECFILE="" Q 8 D ^ECXTRAC,^ECXKILL 9 Q 10 START ;entry point from tasked job 11 N ERR,ECXQDT,ECXNPRFI 12 S QFLG=0,ECED=ECED+.9,ECD=ECSD1,ECXQV="" 13 D QINST I $D(ERR) Q 14 S ECL=+^ACK(509850.8,1,0),ECLINK=^ACK(509850.8,1,"DSS") 15 F S ECD=$O(^ACK(509850.6,"B",ECD)),ECDA=0 Q:(ECD>ECED)!('ECD)!(QFLG) D 16 .I +ECXQV=3,ECD<ECXQDT S ECXQV=2.0 17 .F S ECDA=$O(^ACK(509850.6,"B",ECD,ECDA)) Q:'ECDA D UPDATE Q:QFLG 18 Q 19 QINST ;Get installed information for QUASAR 20 N ARR,IENS,QVIEN,INTIEN 21 S ECXQDT="" 22 D FILE^DID(509850.6,,"VERSION","ARR","ERR") 23 S ECXQV=$G(ARR("VERSION")) I +ECXQV=0 S ERR=1 Q 24 S QVIEN=$$FIND1^DIC(9.4,"","X","QUASAR") I +QVIEN<1 S ERR=1 Q 25 S IENS=","_QVIEN_"," 26 S INTIEN=$$FIND1^DIC(9.49,IENS,"X",ECXQV) I +INTIEN<1 S ERR=1 Q 27 S IENS=INTIEN_","_QVIEN,ECXQDT=$$GET1^DIQ(9.49,IENS,2,"I") 28 Q 29 UPDATE ;create record for each unique CPT code for clinic visit 30 N ARY,ECZNODE,CPT,LOC,MOD,STR,VOL,XX,ECTP,ECV 31 Q:'$D(^ACK(509850.6,ECDA,0)) 32 S ECZNODE=^ACK(509850.6,ECDA,0),EC2NODE=$G(^ACK(509850.6,ECDA,2)) 33 S ECDT=$P(ECZNODE,U),ECDAY=$$ECXDATE^ECXUTL(ECDT,ECXYM) 34 S ECTIME=$$ECXTIME^ECXUTL(ECDT) S:$P(ECDT,".",2)="" ECTIME="000000" 35 S ECXDFN=$P(ECZNODE,U,2) 36 Q:'$$PATDEM^ECXUTL2(ECXDFN,ECD,"1;3;5") 37 S OK=$$PAT^ECXUTL3(ECXDFN,ECDT,"1;5",.ECXPAT) 38 I 'OK S ECXERR=1 K ECXPAT Q 39 ;OEF/OIF data 40 S ECXOEF=ECXPAT("ECXOEF") 41 S ECXOEFDT=ECXPAT("ECXOEFDT") 42 ; 43 S ECHL="",ECXDIV=$P($G(^ACK(509850.6,ECDA,5)),U),ECSTOP=$P(EC2NODE,U) 44 S ECXPDIV=$$GETDIV^ECXDEPT(ECXDIV) ; Get Production Division 45 Q:ECSTOP="" 46 S (ECHLS,ECHL2S)="000",ECAC=$P($G(ECZNODE),U,6) 47 I ECAC D 48 .S ECHL=+$P($G(^SC(ECAC,0)),U,7),ECHL2=+$P($G(^(0)),U,18) I ECHL D 49 ..S ECHLS=$P($G(^DIC(40.7,+ECHL,0)),U,2),ECHL2S=$P($G(^DIC(40.7,+ECHL2,0)),U,2) 50 ..S ECHLS=$$RJ^XLFSTR(ECHLS,3,0),ECHL2S=$$RJ^XLFSTR(ECHL2S,3,0) 51 S ECDSS=ECHLS_ECHL2S 52 I ECXLOGIC>2003 D 53 .I "^18^23^24^36^41^65^94^"[("^"_ECXTS_"^") S ECDSS=$$TSMAP^ECXUTL4(ECXTS) 54 S ECDU=$S(ECSTOP["A":$P(ECLINK,U),ECSTOP["S":$P(ECLINK,U,2),1:"") 55 Q:'ECDU 56 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) 57 Q:'$O(^ACK(509850.6,ECDA,3,0)) 58 ;Create local array of procedure codes and # of times each procedure 59 ; was performed. 60 F I=1:1:4 S @("ECXICD9"_I)="" 61 S (ECDIA,ECXPPC,ECXPRV1,ECXPRV2,ECXPRV3,ECUN1NPI)="" 62 ;if QUASAR v2 63 I +ECXQV=2 D 64 .S ECXPRV1=$P(EC2NODE,U,7),ECXPRV2=$P(EC2NODE,U,3),ECXPRV3=$P(EC2NODE,U,5),ECPN=0 65 .S ECPR1NPI=$$NPI^XUSNPI("Individual_ID",ECXPRV1,ECD) 66 .S:+ECPR1NPI'>0 ECPR1NPI="" S ECPR1NPI=$P(ECPR1NPI,U) 67 .S ECPR2NPI=$$NPI^XUSNPI("Individual_ID",ECXPRV2,ECD) 68 .S:+ECPR2NPI'>0 ECPR2NPI="" S ECPR2NPI=$P(ECPR2NPI,U) 69 .S ECPR3NPI=$$NPI^XUSNPI("Individual_ID",ECXPRV3,ECD) 70 .S:+ECPR3NPI'>0 ECPR3NPI="" S ECPR3NPI=$P(ECPR3NPI,U) 71 .F S ECPN=$O(^ACK(509850.6,ECDA,3,ECPN)) Q:'ECPN D 72 ..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) 73 ..I ECXCPT]"" D 74 ...I '$D(LOC(ECXCPT)) S LOC(ECXCPT)=0_U_ECXPRV1 75 ...S $P(LOC(ECXCPT),U)=$P(LOC(ECXCPT),U)+1 76 .S ECIEN=$O(^ACK(509850.6,ECDA,1,0)),ECDIA=$P($G(^ICD9(+$G(^ACK(509850.6,ECDA,1,ECIEN,0)),0)),U) 77 .F I=1:1:4 S ECIEN=$O(^ACK(509850.6,ECDA,1,ECIEN)) Q:'+ECIEN D 78 ..S @("ECXICD9"_I)=$P($G(^ICD9(+$P(^ACK(509850.6,ECDA,1,ECIEN,0),U),0)),U) 79 ;if QUASAR v3 80 I +ECXQV=3 D 81 .N CPT,DIA,I,J,MOD,MOD1,P,STR,VOL,ECTP,ARY,ECP,ECPN 82 .S ECXPRV2=$G(^ACK(509850.6,ECDA,2.7,1,0)),ECXPRV3=$G(^ACK(509850.6,ECDA,2.7,2,0)) 83 .S ECPN=0 F S ECPN=$O(^ACK(509850.6,ECDA,3,ECPN)) Q:'ECPN D 84 ..S CPT=^ACK(509850.6,ECDA,3,ECPN,0),ECXCPT=$P(CPT,U),ECTP=+$P(CPT,U,5),ECV=1,ECP="" 85 ..Q:ECXCPT="" 86 ..I ECTP D 87 ...S CPT=$G(^ACK(509850.6,ECDA,7,ECTP,0)),ECP=$P(CPT,U) 88 ...S ECP=$S(ECP<90000:$P($G(^EC(725,+ECP,0)),U,2)_"N",1:$P($G(^EC(725,+ECP,0)),U,2)_"L") 89 ...S VOL=+$P(CPT,U,2),ECXPRV1=$P(CPT,U,3) 90 ..I 'ECTP S VOL=+$P(CPT,U,3),ECXPRV1=$P(CPT,U,4) 91 ..S ECXCPT=$E($$CPT^ECXUTL3(ECXCPT),1,5),ECXMOD="",MOD=0 92 ..F S MOD=$O(^ACK(509850.6,ECDA,3,ECPN,1,MOD)) Q:'MOD D 93 ...S MOD1=+^ACK(509850.6,ECDA,3,ECPN,1,MOD,0) D:MOD1 94 ....S ECXMOD=ECXMOD_MOD1_";" 95 ..F I=1:1:$L(ECXMOD,";") I $G(ARY(ECXCPT))'[$P(ECXMOD,";",I) D 96 ...S ARY(ECXCPT)=$G(ARY(ECXCPT))_$P(ECXMOD,";",I)_";" 97 ..S:VOL ECV=VOL 98 ..S ECV=ECV+$G(LOC(ECXCPT)),LOC(ECXCPT)=ECV_U_ECXPRV1_U_ECP 99 .S ECIEN=0 F S ECIEN=$O(^ACK(509850.6,ECDA,1,ECIEN)) Q:'ECIEN D 100 ..S DIA=^ACK(509850.6,ECDA,1,ECIEN,0),P=$P(DIA,U,2),P=$S(P=1:"P",1:"S") 101 ..S CNT=$G(STR(P))+1,STR(P,CNT)=$P($G(^ICD9(+DIA,0)),U),STR(P)=CNT 102 .S ECDIA=$G(STR("P",1)) 103 .F I=1:1:4 Q:'$D(STR("P",I+1)) S @("ECXICD9"_I)=STR("P",I) 104 .S:ECDIA="" ECDIA=$G(STR("S",1)),I=2 105 .F J=I:1:4 Q:'$D(STR("S",J)) S @("ECXICD9"_J)=STR("S",J) 106 Q:('$D(LOC))!('$O(^ACK(509850.6,ECDA,1,0))) 107 ;- Ord Div, Contract St/End Dates, Contract Type placeholders for FY2002 108 S (ECXODIV,ECXCSDT,ECXCEDT,ECXCTYP)="" 109 ;set up Provider Person class 110 S (ECXCPT,ECXPPC1,ECXPPC2,ECXPPC3)="" 111 S:ECXPRV2'="" ECXPPC2=$$PRVCLASS^ECXUTL(ECXPRV2,ECD) 112 S:ECXPRV3'="" ECXPPC3=$$PRVCLASS^ECXUTL(ECXPRV3,ECD) 113 N DA,DIC,DIK,DR,FILEN,DIQ,XVAR,II,DI 114 F II=2,3 S XVAR="ECXPRV"_II I @XVAR'="" D 115 .S DA=@XVAR,(DIC,FILEN)=509850.3,DR=".01",DIQ="ECXQSR",DIQ(0)="I" D EN^DIQ1 116 .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 117 ; -Observation Patient Indicator (yes/no) 118 S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECDSS) 119 ; -CNH status (YES/NO) 120 S ECXCNH=$$CNHSTAT^ECXUTL4(ECXDFN) 121 ;get encounter classification 122 S (ECXAO,ECXECE,ECXIR,ECXMIL,ECXHNC)="",ECXVISIT=$P($G(^ACK(509850.6,ECDA,6)),U,3) 123 I ECXVISIT'="" D 124 .D VISIT^ECXSCX1(ECXDFN,ECXVISIT,.ECXVIST,.ECXERR) I ECXERR K ECXERR Q 125 .S ECXAO=$G(ECXVIST("AO")),ECXECE=$G(ECXVIST("PGE")) 126 .S ECXIR=$G(ECXVIST("IR")),ECXMIL=$G(ECXVIST("MST")),ECXHNC=$G(ECXVIST("HNC")) 127 ; -Head and Neck Cancer Indicator 128 S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) 129 ;get enrollment data (category, status and priority) 130 I $$ENROLLM^ECXUTL2(ECXDFN) 131 ; -Get national patient record flag Indicator if exist 132 D NPRF^ECXUTL5 133 ; -If no encounter number don't file record 134 S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECDT,ECXTS,ECXOBS,ECHEAD,ECDSS,) 135 Q:ECXENC="" 136 ;Loop through array of unique procedures. Create record in ECODE. 137 S CPT="" F S CPT=$O(LOC(CPT)) Q:CPT="" D 138 .S ECV=+$P(LOC(CPT),U),ECXCPT=$$CPT^ECXUTL3(CPT,$G(ARY(CPT)),ECV) 139 .S ECXPRV1=$P(LOC(CPT),U,2) 140 .S:ECXPRV1'="" ECXPPC1=$$PRVCLASS^ECXUTL(ECXPRV1,ECD),ECXPRV1=2_ECXPRV1 141 .S ECP=$P(LOC(CPT),U,3) I ECP="" S ECP=$$CPT^ECXUTL3(CPT,"",ECV) 142 .D FILE^ECXQSR1 143 K CPT,LOC 144 Q 145 SETUP ;Set required input for ECXTRAC 146 S ECHEAD="ECQ" 147 D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) 148 Q 149 QUE ;Entry point for the background requeuing handled by ECXTAUTO. 150 D SETUP,QUE^ECXTAUTO,^ECXKILL Q 1 ECXQSR ;ALB/JAP,BIR/PTD-DSS QUASAR Extract ; 04/16/07 8:58am 2 ;;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 3 BEG ;entry point from option 4 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 5 I '$D(^ACK(509850.8,1,"DSS")) W !,"Linkage has not been established between QUASAR and the DSS UNIT file (#724).",!! Q 6 I '$O(^ACK(509850.6,0)) W !,"There is no data in the A&SP CLINIC VISIT file (#509850.6).",!! Q 7 D SETUP I ECFILE="" Q 8 D ^ECXTRAC,^ECXKILL 9 Q 10 START ;entry point from tasked job 11 N ERR,ECXQDT,ECXNPRFI 12 S QFLG=0,ECED=ECED+.9,ECD=ECSD1,ECXQV="" 13 D QINST I $D(ERR) Q 14 S ECL=+^ACK(509850.8,1,0),ECLINK=^ACK(509850.8,1,"DSS") 15 F S ECD=$O(^ACK(509850.6,"B",ECD)),ECDA=0 Q:(ECD>ECED)!('ECD)!(QFLG) D 16 .I +ECXQV=3,ECD<ECXQDT S ECXQV=2.0 17 .F S ECDA=$O(^ACK(509850.6,"B",ECD,ECDA)) Q:'ECDA D UPDATE Q:QFLG 18 Q 19 QINST ;Get installed information for QUASAR 20 N ARR,IENS,QVIEN,INTIEN 21 S ECXQDT="" 22 D FILE^DID(509850.6,,"VERSION","ARR","ERR") 23 S ECXQV=$G(ARR("VERSION")) I +ECXQV=0 S ERR=1 Q 24 S QVIEN=$$FIND1^DIC(9.4,"","X","QUASAR") I +QVIEN<1 S ERR=1 Q 25 S IENS=","_QVIEN_"," 26 S INTIEN=$$FIND1^DIC(9.49,IENS,"X",ECXQV) I +INTIEN<1 S ERR=1 Q 27 S IENS=INTIEN_","_QVIEN,ECXQDT=$$GET1^DIQ(9.49,IENS,2,"I") 28 Q 29 UPDATE ;create record for each unique CPT code for clinic visit 30 N ARY,ECZNODE,CPT,LOC,MOD,STR,VOL,XX,ECTP,ECV 31 Q:'$D(^ACK(509850.6,ECDA,0)) 32 S ECZNODE=^ACK(509850.6,ECDA,0),EC2NODE=$G(^ACK(509850.6,ECDA,2)) 33 S ECDT=$P(ECZNODE,U),ECDAY=$$ECXDATE^ECXUTL(ECDT,ECXYM) 34 S ECTIME=$$ECXTIME^ECXUTL(ECDT) S:$P(ECDT,".",2)="" ECTIME="000000" 35 S ECXDFN=$P(ECZNODE,U,2) 36 Q:'$$PATDEM^ECXUTL2(ECXDFN,ECD,"1;3;5") 37 S ECHL="",ECXDIV=$P($G(^ACK(509850.6,ECDA,5)),U),ECSTOP=$P(EC2NODE,U) 38 S ECXPDIV=$$GETDIV^ECXDEPT(ECXDIV) ; Get Production Division 39 Q:ECSTOP="" 40 S (ECHLS,ECHL2S)="000",ECAC=$P($G(ECZNODE),U,6) 41 I ECAC D 42 .S ECHL=+$P($G(^SC(ECAC,0)),U,7),ECHL2=+$P($G(^(0)),U,18) I ECHL D 43 ..S ECHLS=$P($G(^DIC(40.7,+ECHL,0)),U,2),ECHL2S=$P($G(^DIC(40.7,+ECHL2,0)),U,2) 44 ..S ECHLS=$$RJ^XLFSTR(ECHLS,3,0),ECHL2S=$$RJ^XLFSTR(ECHL2S,3,0) 45 S ECDSS=ECHLS_ECHL2S 46 I ECXLOGIC>2003 D 47 .I "^18^23^24^36^41^65^94^"[("^"_ECXTS_"^") S ECDSS=$$TSMAP^ECXUTL4(ECXTS) 48 S ECDU=$S(ECSTOP["A":$P(ECLINK,U),ECSTOP["S":$P(ECLINK,U,2),1:"") 49 Q:'ECDU 50 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) 51 Q:'$O(^ACK(509850.6,ECDA,3,0)) 52 ;Create local array of procedure codes and # of times each procedure 53 ; was performed. 54 F I=1:1:4 S @("ECXICD9"_I)="" 55 S (ECDIA,ECXPPC,ECXPRV1,ECXPRV2,ECXPRV3,ECUN1NPI)="" 56 ;if QUASAR v2 57 I +ECXQV=2 D 58 .S ECXPRV1=$P(EC2NODE,U,7),ECXPRV2=$P(EC2NODE,U,3),ECXPRV3=$P(EC2NODE,U,5),ECPN=0 59 .F S ECPN=$O(^ACK(509850.6,ECDA,3,ECPN)) Q:'ECPN D 60 ..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) 61 ..I ECXCPT]"" D 62 ...I '$D(LOC(ECXCPT)) S LOC(ECXCPT)=0_U_ECXPRV1 63 ...S $P(LOC(ECXCPT),U)=$P(LOC(ECXCPT),U)+1 64 .S ECIEN=$O(^ACK(509850.6,ECDA,1,0)),ECDIA=$P($G(^ICD9(+$G(^ACK(509850.6,ECDA,1,ECIEN,0)),0)),U) 65 .F I=1:1:4 S ECIEN=$O(^ACK(509850.6,ECDA,1,ECIEN)) Q:'+ECIEN D 66 ..S @("ECXICD9"_I)=$P($G(^ICD9(+$P(^ACK(509850.6,ECDA,1,ECIEN,0),U),0)),U) 67 ;if QUASAR v3 68 I +ECXQV=3 D 69 .N CPT,DIA,I,J,MOD,MOD1,P,STR,VOL,ECTP,ARY,ECP,ECPN 70 .S ECXPRV2=$G(^ACK(509850.6,ECDA,2.7,1,0)),ECXPRV3=$G(^ACK(509850.6,ECDA,2.7,2,0)) 71 .S ECPN=0 F S ECPN=$O(^ACK(509850.6,ECDA,3,ECPN)) Q:'ECPN D 72 ..S CPT=^ACK(509850.6,ECDA,3,ECPN,0),ECXCPT=$P(CPT,U),ECTP=+$P(CPT,U,5),ECV=1,ECP="" 73 ..Q:ECXCPT="" 74 ..I ECTP D 75 ...S CPT=$G(^ACK(509850.6,ECDA,7,ECTP,0)),ECP=$P(CPT,U) 76 ...S ECP=$S(ECP<90000:$P($G(^EC(725,+ECP,0)),U,2)_"N",1:$P($G(^EC(725,+ECP,0)),U,2)_"L") 77 ...S VOL=+$P(CPT,U,2),ECXPRV1=$P(CPT,U,3) 78 ..I 'ECTP S VOL=+$P(CPT,U,3),ECXPRV1=$P(CPT,U,4) 79 ..S ECXCPT=$E($$CPT^ECXUTL3(ECXCPT),1,5),ECXMOD="",MOD=0 80 ..F S MOD=$O(^ACK(509850.6,ECDA,3,ECPN,1,MOD)) Q:'MOD D 81 ...S MOD1=+^ACK(509850.6,ECDA,3,ECPN,1,MOD,0) D:MOD1 82 ....S ECXMOD=ECXMOD_MOD1_";" 83 ..F I=1:1:$L(ECXMOD,";") I $G(ARY(ECXCPT))'[$P(ECXMOD,";",I) D 84 ...S ARY(ECXCPT)=$G(ARY(ECXCPT))_$P(ECXMOD,";",I)_";" 85 ..S:VOL ECV=VOL 86 ..S ECV=ECV+$G(LOC(ECXCPT)),LOC(ECXCPT)=ECV_U_ECXPRV1_U_ECP 87 .S ECIEN=0 F S ECIEN=$O(^ACK(509850.6,ECDA,1,ECIEN)) Q:'ECIEN D 88 ..S DIA=^ACK(509850.6,ECDA,1,ECIEN,0),P=$P(DIA,U,2),P=$S(P=1:"P",1:"S") 89 ..S CNT=$G(STR(P))+1,STR(P,CNT)=$P($G(^ICD9(+DIA,0)),U),STR(P)=CNT 90 .S ECDIA=$G(STR("P",1)) 91 .F I=1:1:4 Q:'$D(STR("P",I+1)) S @("ECXICD9"_I)=STR("P",I) 92 .S:ECDIA="" ECDIA=$G(STR("S",1)),I=2 93 .F J=I:1:4 Q:'$D(STR("S",J)) S @("ECXICD9"_J)=STR("S",J) 94 Q:('$D(LOC))!('$O(^ACK(509850.6,ECDA,1,0))) 95 ;- Ord Div, Contract St/End Dates, Contract Type placeholders for FY2002 96 S (ECXODIV,ECXCSDT,ECXCEDT,ECXCTYP)="" 97 ;set up Provider Person class 98 S (ECXCPT,ECXPPC1,ECXPPC2,ECXPPC3)="" 99 S:ECXPRV2'="" ECXPPC2=$$PRVCLASS^ECXUTL(ECXPRV2,ECD) 100 S:ECXPRV3'="" ECXPPC3=$$PRVCLASS^ECXUTL(ECXPRV3,ECD) 101 N DA,DIC,DIK,DR,FILEN,DIQ,XVAR,II,DI 102 F II=2,3 S XVAR="ECXPRV"_II I @XVAR'="" D 103 .S DA=@XVAR,(DIC,FILEN)=509850.3,DR=".01",DIQ="ECXQSR",DIQ(0)="I" D EN^DIQ1 104 .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 105 ; -Observation Patient Indicator (yes/no) 106 S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECDSS) 107 ; -CNH status (YES/NO) 108 S ECXCNH=$$CNHSTAT^ECXUTL4(ECXDFN) 109 ;get encounter classification 110 S (ECXAO,ECXECE,ECXIR,ECXMIL,ECXHNC)="",ECXVISIT=$P($G(^ACK(509850.6,ECDA,6)),U,3) 111 I ECXVISIT'="" D 112 .D VISIT^ECXSCX1(ECXDFN,ECXVISIT,.ECXVIST,.ECXERR) I ECXERR K ECXERR Q 113 .S ECXAO=$G(ECXVIST("AO")),ECXECE=$G(ECXVIST("PGE")) 114 .S ECXIR=$G(ECXVIST("IR")),ECXMIL=$G(ECXVIST("MST")),ECXHNC=$G(ECXVIST("HNC")) 115 ; -Head and Neck Cancer Indicator 116 S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) 117 ;get enrollment data (category, status and priority) 118 I $$ENROLLM^ECXUTL2(ECXDFN) 119 ; -Get national patient record flag Indicator if exist 120 D NPRF^ECXUTL5 121 ; -If no encounter number don't file record 122 S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECDT,ECXTS,ECXOBS,ECHEAD,ECDSS,) 123 Q:ECXENC="" 124 ;Loop through array of unique procedures. Create record in ECODE. 125 S CPT="" F S CPT=$O(LOC(CPT)) Q:CPT="" D 126 .S ECV=+$P(LOC(CPT),U),ECXCPT=$$CPT^ECXUTL3(CPT,$G(ARY(CPT)),ECV) 127 .S ECXPRV1=$P(LOC(CPT),U,2) 128 .S:ECXPRV1'="" ECXPPC1=$$PRVCLASS^ECXUTL(ECXPRV1,ECD),ECXPRV1=2_ECXPRV1 129 .S ECP=$P(LOC(CPT),U,3) I ECP="" S ECP=$$CPT^ECXUTL3(CPT,"",ECV) 130 .D FILE 131 K CPT,LOC 132 Q 133 FILE ;file record in #727.825 134 ;node0 135 ;inst^dfn ECXDFN^ssn ECXSSN^name ECXPNM^i/o status ECXA^day ECDAY^ 136 ;DSS unit ECDU^^category ECPTTM^procedure ECP^volume ECV^cost center^ 137 ;ordering sec ^section^provider ECXPRV1^ECXPPC1^ECXPRV2^ECXPPC2^ECXPRV3^ 138 ;ECXPPC3^mov # ECXMN^treat spec ECXTS^time ECTIME^primary care team 139 ;ECPTTM^primary care provider ECPTPR^pce cpt code & modifers ECXCPT^ 140 ;primary icd-9 code ECDIA^secondary icd-9 #1 ECXICD91^secondary icd-9 141 ;#2 ECXICD92^secondary icd-9 #3 ECXICD93^secondary icd-9 #4 ECXICD94^ 142 ;agent orange ECXAST^radiation exposure ECRST^environmental 143 ;contaminants ECEST^service connected ECSC^sent to pce^^dss identifier 144 ;ECDSS^placeholder 145 ;node1 146 ;mpi ECXNPI^dss dept ECXDSSD^provider npi ECUN1NPI^^^pc prov person 147 ;class ECPTNPI^assoc pc provider ECASPR^assoc pc prov person class 148 ;ECCLAS2^assoc pc provider npi ECASNPI^divison ECXDIV^dom ECXDOM^ 149 ;enrollment category ECXCAT^enrollment status ECXSTAT^enrollment prior 150 ;ECXPRIOR^period of service ECXPOS^purple heart ECXPHI^observ pat ind 151 ;ECXOBS^encounter num ECXENC^ao loc ECXAOL^ord div ECXODIV^contr st dt 152 ;ECXCSDT^contr end dt ECXCEDT^contr typ ECXCTYP^CNH stat ECXCNH^ 153 ;production division ECXPDIV^eligibility ECXELIG^ethnicity ECXETH^ 154 ;race1 ECXRC1^enrollment location ECXENRL^^enrollment priority 155 ;ECXPRIOR_enrollment subgroup ECXSBGRP^user enrollee ECXUESTA^patient 156 ;type ECXPTYPE^combat vet elig ECXCVE^combat vet elig end date ECXCVEDT^ 157 ;enc cv eligible ECXCVENC^national patient record flag ECXNPRFI^ 158 ;emergency response indicator(FEMA) ECXERI^agent orange indicator 159 ;ECXAO^environ contam ECXECE^head/neck ECXHNC^military sexual trauma 160 ;ECXMIL^radiation encoun ECXIR^nutrition dx 161 N DA,DIK 162 S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 163 S ECODE=EC7_U_EC23_U 164 S ECODE=ECODE_ECL_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U_ECDAY_U_ECDU_U_U 165 S ECODE=ECODE_ECP_U_ECV_U_ECCS_U_ECO_U_ECM_U_ECXPRV1_U_ECXPPC1_U 166 S ECODE=ECODE_ECXPRV2_U_ECXPPC2_U_ECXPRV3_U_ECXPPC3_U_U 167 S ECODE=ECODE_ECXMN_U_ECXTS_U_ECTIME_U_ECPTTM_U 168 S ECODE=ECODE_ECPTPR_U_ECXCPT_U_ECDIA_U_ECXICD91_U_ECXICD92_U 169 S ECODE=ECODE_ECXICD93_U_ECXICD94_U_ECXAST_U_ECXRST_U_ECXEST_U 170 S ECODE=ECODE_ECSC_U_"N"_U_U_ECDSS_U_U 171 S ECODE1=ECXMPI_U_ECXDSSD_U_ECUN1NPI_U_U_U_ECCLAS_U_ECPTNPI_U_ECASPR_U 172 S ECODE1=ECODE1_ECCLAS2_U_ECASNPI_U_ECXDIV_U_ECXMST_U_ECXDOM_U 173 S ECODE1=ECODE1_ECXDOB_U_ECXCAT_U_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXPOS_U_ECXPHI_U 174 S ECODE1=ECODE1_ECXOBS_U_ECXENC_U_ECXAOL_U_ECXODIV_U_ECXCSDT_U_ECXCEDT_U 175 S ECODE1=ECODE1_ECXCTYP_U_ECXCNH_U_ECXPDIV_U_ECXELIG_U_ECXHNCI_U_ECXETH_U 176 S ECODE1=ECODE1_ECXRC1 177 I ECXLOGIC>2003 S ECODE1=ECODE1_U_ECXENRL 178 I ECXLOGIC>2004 S ECODE1=ECODE1_U_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U 179 I ECXLOGIC>2004 S ECODE2=ECXCVEDT_U_ECXCVENC_U_ECXNPRFI 180 I ECXLOGIC>2006 S ECODE2=ECODE2_U_ECXERI_U_ECXAO_U_ECXECE_U_ECXHNC_U_ECXMIL_U_ECXIR_U 181 S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,^ECX(ECFILE,EC7,2)=$G(ECODE2),ECRN=ECRN+1 182 S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA 183 I $D(ZTQUEUED),$$S^%ZTLOAD 184 Q 185 SETUP ;Set required input for ECXTRAC 186 S ECHEAD="ECQ" 187 D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) 188 Q 189 QUE ;Entry point for the background requeuing handled by ECXTAUTO. 190 D SETUP,QUE^ECXTAUTO,^ECXKILL Q -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXRAD.m
r613 r623 1 ECXRAD ;ALB/JAP,BIR/PDW,PTD-Extract for Radiology ; 5/30/2007 2 ;;3.0;DSS EXTRACTS;**11,8,13,16,24,33,39,46,71,84,92,105**;Dec 22, 1997;Build 70 3 BEG ;entry point from option 4 D SETUP I ECFILE="" Q 5 D ^ECXTRAC,^ECXKILL 6 Q 7 ; 8 START ;start rad extract 9 S QFLG=0 10 K ECXDD D FIELD^DID(70.03,14,,"SPECIFIER","ECXDD") S ECPROF=$E(+$P(ECXDD("SPECIFIER"),"P",2)) K ECXDD 11 S ECXDFN="",ECDT=ECSD-.1,ECED1=ECED+.3 12 F S ECDT=$O(^RADPT("AR",ECDT)) Q:ECDT>ECED1!(ECDT'>0) D Q:QFLG 13 .S ECXDFN="" 14 .F S ECXDFN=$O(^RADPT("AR",ECDT,ECXDFN)) Q:ECXDFN="" I '$D(^TMP("ECL",$J,ECXDFN)) D GET Q:QFLG 15 K ^TMP("ECL",$J) 16 Q 17 ; 18 GET ;get data 19 N ECXIEN,X,SUB,TYPE,ECDOCPC,ECXIS,ECXISPC,ECXPRCL,ECXCSC,ECXUSRTN 20 S ^TMP("ECL",$J,ECXDFN)="" 21 ;with dfn get all exams within date range 22 S ECXMDT=ECSD-.1 23 F S ECXMDT=$O(^RADPT(ECXDFN,"DT","B",ECXMDT)) Q:((ECXMDT>ECED1)!(ECXMDT="")) D Q:QFLG 24 .S ECXMDA=$O(^RADPT(ECXDFN,"DT","B",ECXMDT,"")) Q:ECXMDA="" 25 .S ECXIEN=+$P($G(^RADPT(ECXDFN,"DT",ECXMDA,"P",1,0)),U,11) 26 .S ECTM=$$ECXTIME^ECXUTL(ECXMDT) S:ECTM>235959 ECTM=235959 27 .S ECXDAY=$$ECXDATE^ECXUTL(ECXMDT,ECXYM) 28 .K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECXMDT,"."),"1;3",.ECXPAT) 29 .Q:'OK 30 .S ECXPNM=ECXPAT("NAME"),ECXSSN=ECXPAT("SSN"),ECXMPI=ECXPAT("MPI") 31 .;get emergency response indicator (FEMA) 32 .S ECXERI=ECXPAT("ERI") 33 .S X=$$PRIMARY^ECXUTL2(ECXDFN,$P(ECXMDT,"."),ECPROF) 34 .S ECPTTM=$P(X,U,1),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4) 35 .S ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7) 36 .S X=$$INP^ECXUTL2(ECXDFN,ECXMDT),ECXA=$P(X,U),ECXMN=$P(X,U,2) 37 .S ECXTS=$P(X,U,3),ECXDOM=$P(X,U,10),ECXADMDT=$P(X,U,4) 38 .; 39 .;- Observation patient indicator (YES/NO) 40 .S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS) 41 .;for dfn & date get exam(s) ien 42 .S ECXMDA="" 43 .F S ECXMDA=$O(^RADPT(ECXDFN,"DT","B",ECXMDT,ECXMDA)) Q:+ECXMDA=0 D 44 ..S ECXDIV=$P(^RADPT(ECXDFN,"DT",ECXMDA,0),U,3),ECLOC=$P(^(0),U,4),ECTY=$P(^(0),U,2) 45 ..; 46 ..;- Ordering stop code (based on imaging location) 47 ..S ECXORDST=$$GET1^DIQ(40.7,$$GET1^DIQ(79.1,$G(ECLOC),22,"I"),1) 48 ..; 49 ..;- Get ordering date using Imaging Order ptr to #75.1 in subfile 70.03 50 ..S ECXIEN=+$P($G(^RADPT(ECXDFN,"DT",ECXMDA,"P",1,0)),U,11) 51 ..S ECXORDDT=$$ECXDATE^ECXUTL($P($G(^RAO(75.1,ECXIEN,0)),U,16),ECXYM) 52 ..; 53 ..;- If no encounter number don't file record 54 ..S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXMDT,ECXTS,ECXOBS,ECHEAD,ECTY,) Q:ECXENC="" 55 ..;procedures and modifiers for specific exam (case numbers) 56 ..;ward/clinic,service,provider,diagnostic code 57 ..S ECCN=0 58 ..F S ECCN=$O(^RADPT(ECXDFN,"DT",ECXMDA,"P",ECCN)) Q:ECCN'>0 D 59 ...S ECCA=^RADPT(ECXDFN,"DT",ECXMDA,"P",ECCN,0) 60 ...S ECXW=$P(ECCA,U,6),ECXW=$P($G(^DIC(42,+ECXW,44)),U) 61 ...S:ECXW="" ECXW=$P(ECCA,U,8) 62 ...S ECDOCNPI=$$NPI^XUSNPI("Individual_ID",$P(ECCA,U,14),ECDT) 63 ...S:+ECDOCNPI'>0 ECDOCNPI="" S ECDOCNPI=$P(ECDOCNPI,U) 64 ...S (ECXDSSD,ECXDSSP)="" 65 ...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) 66 ...S ECPRO=$P(ECCA,U,2),ECSTAT=$P($G(^RA(72,+$P(ECCA,U,3),0)),U,3) 67 ...;get the primary interpreting staff and the person class DBIA #65 68 ...S ECXIS=$P(ECCA,U,15),ECXISPC=$$PRVCLASS^ECXUTL(ECXIS,ECDT) 69 ...S ECISNPI=$$NPI^XUSNPI("Individual_ID",ECXIS,ECDT) 70 ...S:+ECISNPI'>0 ECISNPI="" S ECISNPI=$P(ECISNPI,U) 71 ...;prefix interpreting radiologist with a "2" if not null 72 ...S ECXIS=$S(ECXIS:"2"_ECXIS,1:"") 73 ...;get the principal clinic ien DBIA #65 74 ...S ECXPRCL=$P(ECCA,U,8) 75 ...;get the clinic stop code from file #44 76 ...S ECXCSC=$$GET1^DIQ(40.7,$$GET1^DIQ(44,ECXPRCL,8,"I"),1) 77 ...Q:'ECPRO 78 ...Q:+ECSTAT=0 79 ...;get CPT code & modifiers 80 ...S ECPT=+$P($G(^RAMIS(71,+ECPRO,0)),U,9),ECXCMOD="" 81 ...;quit if this is a 'parent' procedure 82 ...S TYPE=$P($G(^RAMIS(71,+ECPRO,0)),U,6) 83 ...Q:((ECPT=0)&(TYPE="P")) 84 ...;if site is using radiology with cpt modifiers then get them 85 ...K ARR,ERR D FIELD^DID(70.03,135,,"LABEL","ARR","ERR") 86 ...I $D(ARR("LABEL")) D 87 ....K ARR,ERR D FIELD^DID(70.03,135,,"GLOBAL SUBSCRIPT LOCATION","ARR","ERR") 88 ....Q:$D(ERR("DIERR")) 89 ....S SUB=$P(ARR("GLOBAL SUBSCRIPT LOCATION"),";") S ECMOD=0 90 ....Q:'$D(^RADPT(ECXDFN,"DT",ECXMDA,"P",ECCN,SUB)) 91 ....F S ECMOD=$O(^RADPT(ECXDFN,"DT",ECXMDA,"P",ECCN,SUB,ECMOD)) Q:ECMOD'>0 S ECXCMOD=ECXCMOD_$P(^(ECMOD,0),U)_";" 92 ...S ECXCPT=$$CPT^ECXUTL3(ECPT,ECXCMOD) 93 ...;get procedure radiology modifiers 94 ...S ECMOD=0,ECMODS="" 95 ...F S ECMOD=$O(^RADPT(ECXDFN,"DT",ECXMDA,"P",ECCN,"M",ECMOD)) Q:ECMOD'>0 S ECMODS=ECMODS_$P(^(ECMOD,0),U)_";" 96 ...S ECXPDIV=$$RADDIV^ECXDEPT(ECXDIV) ;p-46 97 ...D FILE 98 Q 99 ; 100 FILE ;file record 101 ;node0 102 ;rad div^dfn^ssn^name^in/out (ECXA)^day^cpt code^procedure^img loc^ward^ 103 ;ser^diag code^req physician^modifiers^mov #^treat spec^time^ 104 ;imaging type^primary care team^primary care provider 105 ;node1 106 ;mpi^dss dept^placeholder^placeholder^pc prov person class^ 107 ;assoc pc provider^assoc pc prov person class^placeholder^dom^ 108 ;observ pat ind^encounter num^ord stop code^ord date^division^ 109 ;dss product ECXDSSP^requesting provider person class ECDOCPC^interp- 110 ;reting radiologist ECXIS^interpreting radiologist pc ECXISPC^princi- 111 ;pal clinic ECXPRCL^clinc stop code ECXCSC^emergency response indicator 112 ;(FEMA) ECXERI^assoc pc provider npi^interpreting rad npi^pc provider npi^req physician npi 113 N DA,DIK 114 S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 115 S ECODE=EC7_U_EC23_U_ECXDIV_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U 116 S ECODE=ECODE_ECXDAY_U_ECXCPT_U_ECPRO_U_ECLOC_U_ECXW_U_ECS_U_ECDI_U 117 S ECODE=ECODE_ECDOC_U_ECMODS_U_ECXMN_U_ECXTS_U_ECTM_U_ECTY_U_ECPTTM_U 118 S ECODE=ECODE_ECPTPR_U 119 S ECODE1=ECXMPI_U_ECXDSSD_U_U_U_ECCLAS_U_ECASPR_U 120 S ECODE1=ECODE1_ECCLAS2_U_U_ECXDOM_U_ECXOBS_U_ECXENC_U_ECXORDST_U 121 S ECODE1=ECODE1_ECXORDDT_U_ECXPDIV_U 122 I ECXLOGIC>2004 S ECODE1=ECODE1_ECXDSSP_U_ECDOCPC 123 I ECXLOGIC>2005 S ECODE1=ECODE1_U_ECXIS_U_ECXISPC_U_ECXPRCL_U_ECXCSC 124 I ECXLOGIC>2006 S ECODE1=ECODE1_U_ECXERI 125 I ECXLOGIC>2007 S ECODE1=ECODE1_U_ECASNPI_U_ECISNPI_U_ECPTNPI_U_ECDOCNPI 126 S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,ECRN=ECRN+1 127 S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA 128 I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 129 Q 130 ; 131 SETUP ;Set required input for ECXTRAC 132 S ECHEAD="RAD" 133 D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) 134 Q 1 ECXRAD ;ALB/JAP,BIR/PDW,PTD-Extract for Radiology ; 6/23/06 6:52am 2 ;;3.0;DSS EXTRACTS;**11,8,13,16,24,33,39,46,71,84,92**;Dec 22, 1997;Build 30 3 BEG ;entry point from option 4 D SETUP I ECFILE="" Q 5 D ^ECXTRAC,^ECXKILL 6 Q 7 ; 8 START ;start rad extract 9 S QFLG=0 10 K ECXDD D FIELD^DID(70.03,14,,"SPECIFIER","ECXDD") S ECPROF=$E(+$P(ECXDD("SPECIFIER"),"P",2)) K ECXDD 11 S ECXDFN="",ECDT=ECSD-.1,ECED1=ECED+.3 12 F S ECDT=$O(^RADPT("AR",ECDT)) Q:ECDT>ECED1!(ECDT'>0) D Q:QFLG 13 .S ECXDFN="" 14 .F S ECXDFN=$O(^RADPT("AR",ECDT,ECXDFN)) Q:ECXDFN="" I '$D(^TMP("ECL",$J,ECXDFN)) D GET Q:QFLG 15 K ^TMP("ECL",$J) 16 Q 17 ; 18 GET ;get data 19 N ECXIEN,X,SUB,TYPE,ECDOCPC,ECXIS,ECXISPC,ECXPRCL,ECXCSC 20 S ^TMP("ECL",$J,ECXDFN)="" 21 ;with dfn get all exams within date range 22 S ECXMDT=ECSD-.1 23 F S ECXMDT=$O(^RADPT(ECXDFN,"DT","B",ECXMDT)) Q:((ECXMDT>ECED1)!(ECXMDT="")) D Q:QFLG 24 .S ECXMDA=$O(^RADPT(ECXDFN,"DT","B",ECXMDT,"")) Q:ECXMDA="" 25 .S ECXIEN=+$P($G(^RADPT(ECXDFN,"DT",ECXMDA,"P",1,0)),U,11) 26 .S ECTM=$$ECXTIME^ECXUTL(ECXMDT) S:ECTM>235959 ECTM=235959 27 .S ECXDAY=$$ECXDATE^ECXUTL(ECXMDT,ECXYM) 28 .K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECXMDT,"."),"1;3",.ECXPAT) 29 .Q:'OK 30 .S ECXPNM=ECXPAT("NAME"),ECXSSN=ECXPAT("SSN"),ECXMPI=ECXPAT("MPI") 31 .;get emergency response indicator (FEMA) 32 .S ECXERI=ECXPAT("ERI") 33 .S X=$$PRIMARY^ECXUTL2(ECXDFN,$P(ECXMDT,"."),ECPROF) 34 .S ECPTTM=$P(X,U,1),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4) 35 .S ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7) 36 .S X=$$INP^ECXUTL2(ECXDFN,ECXMDT),ECXA=$P(X,U),ECXMN=$P(X,U,2) 37 .S ECXTS=$P(X,U,3),ECXDOM=$P(X,U,10),ECXADMDT=$P(X,U,4) 38 .; 39 .;- Observation patient indicator (YES/NO) 40 .S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS) 41 .;for dfn & date get exam(s) ien 42 .S ECXMDA="" 43 .F S ECXMDA=$O(^RADPT(ECXDFN,"DT","B",ECXMDT,ECXMDA)) Q:+ECXMDA=0 D 44 ..S ECXDIV=$P(^RADPT(ECXDFN,"DT",ECXMDA,0),U,3),ECLOC=$P(^(0),U,4),ECTY=$P(^(0),U,2) 45 ..; 46 ..;- Ordering stop code (based on imaging location) 47 ..S ECXORDST=$$GET1^DIQ(40.7,$$GET1^DIQ(79.1,$G(ECLOC),22,"I"),1) 48 ..; 49 ..;- Get ordering date using Imaging Order ptr to #75.1 in subfile 70.03 50 ..S ECXIEN=+$P($G(^RADPT(ECXDFN,"DT",ECXMDA,"P",1,0)),U,11) 51 ..S ECXORDDT=$$ECXDATE^ECXUTL($P($G(^RAO(75.1,ECXIEN,0)),U,16),ECXYM) 52 ..; 53 ..;- If no encounter number don't file record 54 ..S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXMDT,ECXTS,ECXOBS,ECHEAD,ECTY,) Q:ECXENC="" 55 ..;procedures and modifiers for specific exam (case numbers) 56 ..;ward/clinic,service,provider,diagnostic code 57 ..S ECCN=0 58 ..F S ECCN=$O(^RADPT(ECXDFN,"DT",ECXMDA,"P",ECCN)) Q:ECCN'>0 D 59 ...S ECCA=^RADPT(ECXDFN,"DT",ECXMDA,"P",ECCN,0) 60 ...S ECXW=$P(ECCA,U,6),ECXW=$P($G(^DIC(42,+ECXW,44)),U) 61 ...S:ECXW="" ECXW=$P(ECCA,U,8) 62 ...S (ECXDSSD,ECXDSSP)="" 63 ...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) 64 ...S ECPRO=$P(ECCA,U,2),ECSTAT=$P($G(^RA(72,+$P(ECCA,U,3),0)),U,3) 65 ...;get the primary interpreting staff and the person class DBIA #65 66 ...S ECXIS=$P(ECCA,U,15),ECXISPC=$$PRVCLASS^ECXUTL(ECXIS,ECDT) 67 ...;prefix interpreting radiologist with a "2" if not null 68 ...S ECXIS=$S(ECXIS:"2"_ECXIS,1:"") 69 ...;get the principal clinic ien DBIA #65 70 ...S ECXPRCL=$P(ECCA,U,8) 71 ...;get the clinic stop code from file #44 72 ...S ECXCSC=$$GET1^DIQ(40.7,$$GET1^DIQ(44,ECXPRCL,8,"I"),1) 73 ...Q:'ECPRO 74 ...Q:+ECSTAT=0 75 ...;get CPT code & modifiers 76 ...S ECPT=+$P($G(^RAMIS(71,+ECPRO,0)),U,9),ECXCMOD="" 77 ...;quit if this is a 'parent' procedure 78 ...S TYPE=$P($G(^RAMIS(71,+ECPRO,0)),U,6) 79 ...Q:((ECPT=0)&(TYPE="P")) 80 ...;if site is using radiology with cpt modifiers then get them 81 ...K ARR,ERR D FIELD^DID(70.03,135,,"LABEL","ARR","ERR") 82 ...I $D(ARR("LABEL")) D 83 ....K ARR,ERR D FIELD^DID(70.03,135,,"GLOBAL SUBSCRIPT LOCATION","ARR","ERR") 84 ....Q:$D(ERR("DIERR")) 85 ....S SUB=$P(ARR("GLOBAL SUBSCRIPT LOCATION"),";") S ECMOD=0 86 ....Q:'$D(^RADPT(ECXDFN,"DT",ECXMDA,"P",ECCN,SUB)) 87 ....F S ECMOD=$O(^RADPT(ECXDFN,"DT",ECXMDA,"P",ECCN,SUB,ECMOD)) Q:ECMOD'>0 S ECXCMOD=ECXCMOD_$P(^(ECMOD,0),U)_";" 88 ...S ECXCPT=$$CPT^ECXUTL3(ECPT,ECXCMOD) 89 ...;get procedure radiology modifiers 90 ...S ECMOD=0,ECMODS="" 91 ...F S ECMOD=$O(^RADPT(ECXDFN,"DT",ECXMDA,"P",ECCN,"M",ECMOD)) Q:ECMOD'>0 S ECMODS=ECMODS_$P(^(ECMOD,0),U)_";" 92 ...S ECXPDIV=$$RADDIV^ECXDEPT(ECXDIV) ;p-46 93 ...D FILE 94 Q 95 ; 96 FILE ;file record 97 ;node0 98 ;rad div^dfn^ssn^name^in/out (ECXA)^day^cpt code^procedure^img loc^ward^ 99 ;ser^diag code^req physician^modifiers^mov #^treat spec^time^ 100 ;imaging type^primary care team^primary care provider 101 ;node1 102 ;mpi^dss dept^req physician npi^pc provider npi^pc prov person class^ 103 ;assoc pc provider^assoc pc prov person class^assoc pc prov npi^dom^ 104 ;observ pat ind^encounter num^ord stop code^ord date^division^ 105 ;dss product ECXDSSP^requesting provider person class ECDOCPC^interp- 106 ;reting radiologist ECXIS^interpreting radiologist pc ECXISPC^princi- 107 ;pal clinic ECXPRCL^clinc stop code ECXCSC^emergency response indicator 108 ;(FEMA) ECXERI 109 N DA,DIK 110 S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 111 S ECODE=EC7_U_EC23_U_ECXDIV_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U 112 S ECODE=ECODE_ECXDAY_U_ECXCPT_U_ECPRO_U_ECLOC_U_ECXW_U_ECS_U_ECDI_U 113 S ECODE=ECODE_ECDOC_U_ECMODS_U_ECXMN_U_ECXTS_U_ECTM_U_ECTY_U_ECPTTM_U 114 S ECODE=ECODE_ECPTPR_U 115 S ECODE1=ECXMPI_U_ECXDSSD_U_ECDOCNPI_U_ECPTNPI_U_ECCLAS_U_ECASPR_U 116 S ECODE1=ECODE1_ECCLAS2_U_ECASNPI_U_ECXDOM_U_ECXOBS_U_ECXENC_U_ECXORDST_U 117 S ECODE1=ECODE1_ECXORDDT_U_ECXPDIV_U 118 I ECXLOGIC>2004 S ECODE1=ECODE1_ECXDSSP_U_ECDOCPC 119 I ECXLOGIC>2005 S ECODE1=ECODE1_U_ECXIS_U_ECXISPC_U_ECXPRCL_U_ECXCSC 120 I ECXLOGIC>2006 S ECODE1=ECODE1_U_ECXERI 121 S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,ECRN=ECRN+1 122 S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA 123 I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 124 Q 125 ; 126 SETUP ;Set required input for ECXTRAC 127 S ECHEAD="RAD" 128 D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) 129 Q -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXSCLD.m
r613 r623 1 ECXSCLD ;BIR/DMA,CML-Enter, Print and Edit Entries in 728.44 ; 5/24/07 3:49pm2 ;;3.0;DSS EXTRACTS;**2,8,24,30,71,80,105**;Dec 22, 1997;Build 70 3 EN 4 5 6 7 8 9 START 10 11 12 13 14 15 16 FIX 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 PRINT 37 38 39 40 41 42 43 44 45 SPRINT 46 47 48 49 50 51 52 53 54 55 56 HEAD 57 58 59 60 61 62 W !!,?1,"CLINIC",?31,"STOP",?38,"CREDIT",?47,"DSS",?54,"DSS",?63,"ACTION",?71,"NAT'L"63 W !,?31,"CODE",?38,"STOP",?47,"STOP",?54,"CREDIT",?71,"CODE",!,?1,"(* - currently inactive)",?38,"CODE",?47,"CODE",?54,"CODE",!,LN Q64 65 SHOWEM 66 67 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:"_____")68 S ECN=$P($G(^ECX(728.441,+$P(ECD,U,7),0)),U) W ?71,$S(ECN]"":ECN,1:"____")69 70 SS 71 72 73 74 75 EDIT 76 77 78 79 80 APPROVE 81 82 83 84 85 86 87 88 89 90 91 APPLOOP 92 93 94 END 95 96 97 LOOK 98 99 100 101 102 103 1 ECXSCLD ;BIR/DMA,CML-Enter, Print and Edit Entries in 728.44 ; 9/21/04 7:33am 2 ;;3.0;DSS EXTRACTS;**2,8,24,30,71,80**;Dec 22, 1997 3 EN ;entry point from option 4 ;load entries 5 W !!,"This option creates local entries in the DSS CLINIC AND STOP CODES file.",! 6 I '$D(^ECX(728.44)) W !,"DSS Clinic stop code file does not exist",!! R X:5 K X Q 7 K ZTSAVE S ZTDESC="Gather Clinic stop codes for DSS",ZTRTN="START^ECXSCLD",ZTIO="" D ^%ZTLOAD 8 Q 9 START ; entry point 10 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 11 K DIK S DIK="^ECX(728.44,",DIK(1)=".01^B" D ENALL^DIK 12 ;S $P(^ECX(728.44,0),U,3,4)=ECL_U_ECNT 13 K ZTDESC,EC,J,ECD,ECD2,ECL,ECS,ECS2,ECP 14 S ZTREQ="@" Q 15 ; 16 FIX ; get stop codes and default style for feeder key 17 ; 1 if no credit stop code - 5 if credit stop code exists 18 K ECD2,ECS2 I $D(^ECX(728.44,EC,0)) S ECD2=^(0) F ECS=2,3 S ECS2(ECS)=$P(ECD2,U,ECS) 19 S ID=+DAT,RD=$P(DAT,U,2) 20 I $D(ECD2) D 21 .I ID,ID'>DT I 'RD!(RD>DT) S:$P(ECD2,U,10)'=ID $P(ECD2,U,7)="" S $P(ECD2,U,10)=ID 22 .I ID,RD,RD'>DT S:$P(ECD2,U,10) $P(ECD2,U,7)="" S $P(ECD2,U,10)="" 23 .I ID,ID>DT S:$P(ECD2,U,10) $P(ECD2,U,7)="" S $P(ECD2,U,10)="" 24 .I 'ID,$P(ECD2,U,10) S $P(ECD2,U,7)="",$P(ECD2,U,10)="" 25 F ECS=7,18 S ECP=+$P(ECD,U,ECS),ECS(ECS)=$P($G(^DIC(40.7,ECP,0)),U,2) 26 S ECDF=$S(ECS(18)]"":5,1:1) S:$P(ECD,U,17)="Y" ECDF=6 S:$G(^SC(EC,"OOS")) ECDF=6 27 S ECL=EC,ECD=EC_U_ECS(7)_U_ECS(18) 28 I '$D(ECD2) D 29 .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 30 I $D(ECD2) D 31 .S $P(ECD2,U,1,3)=ECD 32 .I +ECS(7)'=+ECS2(2)!(+ECS(18)'=+ECS2(3)) S $P(ECD2,U,7)="" 33 .S ^ECX(728.44,EC,0)=ECD2 34 Q 35 ; 36 PRINT ; print worksheet for updates 37 I '$O(^ECX(728.44,0)) W !,"DSS Clinic stop code file does not exist",!! R X:5 K X Q 38 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" 39 W !,"defined as ""inactive"" by MAS the last time the option ""Create DSS Clinic",!,"Stop Code File"" was run will be indicated with an ""*"".",! 40 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." 41 D ^DIR K DIR G END:$D(DIRUT) S ECALL=$E(Y) 42 S %ZIS="Q" D ^%ZIS Q:POP 43 I $D(IO("Q")) K ZTSAVE S ZTDESC="DSS clinic stop code work sheet",ZTRTN="SPRINT^ECXSCLD",ZTSAVE("ECALL")="" D ^%ZTLOAD,HOME^%ZIS Q 44 U IO 45 SPRINT ; queued entry to print work sheet 46 S QFLG=0,$P(LN,"-",81)="",PG=0 47 S ECDATE=$O(^ECX(728.44,"A1","")) I ECDATE S ECDATE=-ECDATE,ECDATE=$$FMTE^XLFDT(ECDATE,"5DF"),ECDATE=$TR(ECDATE," ","0") 48 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) 49 D HEAD S ECSC="" I $O(^TMP("EC",$J,ECSC))="" W !!,"NO DATA FOUND FOR WORKSHEET.",! G END 50 F J=1:1 S ECSC=$O(^TMP("EC",$J,ECSC)) Q:ECSC="" S ECD=^(ECSC) D SHOWEM Q:QFLG 51 I $E(IOST)="C",'QFLG D SS 52 K ^TMP("EC",$J),J,ECSC,ECSD,ECDATE,QFLG,PG,LN,SS 53 W:$Y @IOF D ^%ZISC S ZTREQ="@" 54 Q 55 ; 56 HEAD ; header for worksheet 57 D SS Q:QFLG 58 S PG=PG+1 W:$Y!($E(IOST)="C") @IOF W !,"WORKSHEET FOR DSS CLINIC STOPS",?71,"Page: ",PG 59 I ECDATE]"" W !,"(last reviewed on ",ECDATE,")" 60 E W !,"(NEVER REVIEWED)" 61 W ! 62 W !!,?1,"CLINIC",?27,"STOP",?34,"CREDIT",?43,"DSS",?50,"DSS",?59,"ACTION",?67,"NAT'L",?74,"DSS" 63 W !,?27,"CODE",?34,"STOP",?43,"STOP",?50,"CREDIT",?67,"CODE",?74,"DEPT",!,?1,"(* - currently inactive)",?34,"CODE",?43,"CODE",?50,"CODE",!,LN Q 64 ; 65 SHOWEM ; list clinics for worksheet 66 I $Y+4>IOSL D HEAD Q:QFLG 67 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:"_____") 68 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:"___") 69 Q 70 SS ;SCROLL STOPS 71 I $E(IOST)="C" S SS=22-$Y F JJ=1:1:SS W ! 72 I $E(IOST)="C",PG>0 S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q 73 Q 74 ; 75 EDIT ; put in DSS stopcodes and which one to send 76 I '$O(^ECX(728.44,0)) W !,"DSS Clinic stop code file does not exist",!! R X:5 K X Q 77 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) 78 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 79 ; 80 APPROVE ; approve current DSS Stop and Credit Stop codes 81 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" 82 W !,"from the list printed from the ""Clinic and DSS Stop Codes Print"" when you",!,"choose to print only ""unreviewed"" clinics.",! 83 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" 84 S DIR("?",1)=" Enter:" 85 S DIR("?",2)=" ""YES"" if you concur with the ""Clinic and DSS Stop Codes Print""," 86 S DIR("?",3)=" ""NO"" or <RET> if you do not want to approve the current information," 87 S DIR("?")=" ""^"" to exit option." 88 D ^DIR K DIR I 'Y!($D(DIRUT)) G END 89 W ! S ZTRTN="APPLOOP^ECXSCLD",ZTIO="",ZTDESC="Approve DSS stop codes for clinic extract" D ^%ZTLOAD W !!,"...approval queued" G END 90 ; 91 APPLOOP ; queued entry to approve action codes 92 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 93 S ZTREQ="@" G END 94 END K X,Y,DA,DR,DIC,DIE,QFLG,PG,LN 95 Q 96 ; 97 LOOK ;queued entry to check for new clinics 98 S ECD=$E(DT,1,5)-1-($E(DT,4,5)="01"*8800),ECD0=ECD_"00",ECXMISS=10,ECGRP="SCX" K ^TMP("ECXS",$J) 99 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 100 .S ID=+DAT,RD=$P(DAT,U,2) I ID,ID<DT I 'RD!(RD>DT) Q 101 .S ^TMP("ECXS",$J,ECXMISS,0)=$J(EC,6)_" "_$$LJ^XLFSTR($P(^SC(EC,0),U),40),ECXMISS=ECXMISS+1 102 D ^ECXSCX1 103 Q -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXSCX1.m
r613 r623 1 ECXSCX1 ;ALB/JAP,BIR/DMA-Clinic Extract Message ; 4/11/07 3:26pm 2 ;;3.0;DSS EXTRACTS;**8,28,24,27,29,30,31,33,84,92,105**;Dec 22, 1997;Build 70 3 EN ;entry point from ecxscx 4 N ECX 5 ;send missing clinic message 6 S ECX=$O(^TMP($J,"ECXS","MISS",0)) D 7 .Q:ECX="" 8 .S XMSUB="MISSING CLINICS in File #728.44",XMDUZ="DSS SYSTEM" 9 .K XMY S XMY("G.DSS-"_ECGRP_"@"_^XMB("NETNAME"))="" 10 .F ECX=1:1:5 S ^TMP($J,"ECXS","MISS",ECX,0)=$P($T(MSG+ECX),";;",2) 11 .S XMTEXT="^TMP($J,""ECXS"",""MISS""," D ^XMD 12 ;send no division message 13 S ECX=$O(^TMP($J,"ECXS","DIV",0)) D 14 .Q:ECX="" 15 .S XMSUB="CLINICS w/o DIVISION Data",XMDUZ="DSS SYSTEM" 16 .K XMY S XMY("G.DSS-"_ECGRP_"@"_^XMB("NETNAME"))="" 17 .F ECX=1:1:5 S ^TMP($J,"ECXS","DIV",ECX,0)=$P($T(MSG2+ECX),";;",2) 18 .S XMTEXT="^TMP($J,""ECXS"",""DIV""," D ^XMD 19 ;cleanup 20 K ^TMP($J,"ECXS") 21 Q 22 MSG ;text for missing clinic 23 ;;The following clinics have not been entered into the CLINIC AND 24 ;;STOP CODES file (#728.44). If any listed clinic is currently 25 ;;active, please use the options 'Create DSS Clinic Stop Code File' 26 ;;and 'Enter/Edit DSS Stop Codes for Clinics' to update this file. 27 ;; 28 ; 29 MSG2 ;text for missing division 30 ;;The following clinics in the HOSPITAL LOCATION file (#44) have not 31 ;;been assigned to a division from the MEDICAL CENTER DIVISION file 32 ;;(#40.8). CLI extract records associated with these clinics have 33 ;;been given a default Division identifier of "1". 34 ;; 35 ; 36 MISS ;load ^tmp if clinic missing from #728.44 37 N DAT,ID,RD 38 S (ID,RD)="" 39 S DAT=$G(^SC(SC,"I")) I DAT]"" S ID=+DAT,RD=$P(DAT,U,2) 40 ;ignore inactive clinics 41 I ID,ID<DT I 'RD!(RD>DT) Q 42 I '$D(^TMP($J,"ECXS","ECXMISS")) S ^TMP($J,"ECXS","ECXMISS")=10 43 S ECXMISS=^TMP($J,"ECXS","ECXMISS") 44 S ^TMP($J,"ECXS","MISS",ECXMISS,0)=$J(SC,6)_" "_$$LJ^XLFSTR($P(^SC(SC,0),U),40)_ECSC_"/"_ECCSC 45 S ^TMP($J,"ECXS","ECXMISS")=ECXMISS+1 46 Q 47 ; 48 NODIV ;load ^tmp if clinic w/o division 49 N DAT,ID,RD 50 S (ID,RD)="" 51 S DAT=$G(^SC(SC,"I")) I DAT]"" S ID=+DAT,RD=$P(DAT,U,2) 52 ;ignore inactive clinics 53 I ID,ID<DT I 'RD!(RD>DT) Q 54 I '$D(^TMP($J,"ECXS","ECXMISS")) S ^TMP($J,"ECXS","ECXMISS")=10 55 S ECXMISS=^TMP($J,"ECXS","ECXMISS") 56 S ^TMP($J,"ECXS","DIV",ECXMISS,0)=$J(SC,6)_" "_$$LJ^XLFSTR($P(^SC(SC,0),U),40) 57 S ^TMP($J,"ECXS","ECXMISS")=ECXMISS+1 58 Q 59 ; 60 FEEDER(ECXSC,ECXSD,ECXP1,ECXP2,ECXP3,ECXSEND,ECXDIV) ;get transmission style and feeder key variables 61 ;feeder key = primary stop code_secondary stop code_length of appointment_national clinic code_noshow indicator 62 ; input 63 ; ECXSC = ien of clinic in file #44 (required) 64 ; ECXSD = start date of extract date range (required) 65 ; ECXP1,ECXP2,ECXP3,ECXSEND passed by reference (required) 66 ; output (passed-by-reference variables) 67 ; ECXP1 = primary stop code 68 ; ECXP2 = secondary stop code 69 ; ECXP3 = field #7 of file #728.44 70 ; ECXSEND = field #5 of file #728.44 71 ; ECXDIV = field #3.5 of file #44 72 N ECSC,ECCSC,ECSD1,ECXNC,ECXMISS,CLIN,SC 73 S (ECXP1,ECXP2)="000",ECXP3="0000" 74 S ECXSEND=1,ECXDIV=0 75 Q:+ECXSC=0 76 ;get needed data from ^tmp 77 I $D(^TMP($J,"ECXS","SC",ECXSC)) D 78 .S CLIN=^TMP($J,"ECXS","SC",ECXSC) 79 .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) 80 .S ECXDIV=+$P($G(^TMP($J,"ECXCL",ECXSC)),U,4) S:ECXDIV=0 ECXDIV=1 81 ;otherwise, set needed data in ^tmp 82 I '$D(^TMP($J,"ECXS","SC",ECXSC)) D 83 .;get division or send no division msg 84 .S ECXDIV=+$P($G(^TMP($J,"ECXCL",ECXSC)),U,4) 85 .I ECXDIV=0 S SC=ECXSC D NODIV S ECXDIV=1 86 .;get other data from file #44 if no #727.44 record; send missing clinic msg 87 .I '$D(^ECX(728.44,ECXSC,0)) D 88 ..S ECSC=+$P($G(^SC(ECXSC,0)),U,7),ECCSC=+$P(^(0),U,18) 89 ..S SC=ECXSC,ECSD1=ECXSD D MISS 90 ..S:ECSC ECXP1=$P($G(^DIC(40.7,ECSC,0)),U,2),ECXP1=$$RJ^XLFSTR(+ECXP1,3,0) 91 .;otherwise get other data from file #728.44 92 .S EC=$G(^ECX(728.44,ECXSC,0)) D 93 ..Q:EC="" 94 ..S ECXSEND=$P(EC,U,6) 95 ..Q:ECXSEND=6 96 ..S ECSC=+$P(EC,U,4),ECCSC=+$P(EC,U,5) 97 ..I 'ECSC S ECSC=+$P(EC,U,2),ECCSC=+$P(EC,U,3) 98 ..I ECSC S ECXP1=$$RJ^XLFSTR(ECSC,3,0),ECXP2=$$RJ^XLFSTR(ECCSC,3,0) 99 ..;if primary stop not valid, use file #44 record 100 ..I 'ECSC S ECSC=+$P($G(^SC(ECXSC,0)),U,7),ECCSC=+$P($G(^(0)),U,18) I ECSC D 101 ...S ECXP1=+$P($G(^DIC(40.7,ECSC,0)),U,2) 102 ...S:ECCSC ECXP2=+$P($G(^DIC(40.7,ECCSC,0)),U,2) 103 ...S ECXP1=$$RJ^XLFSTR(ECXP1,3,0),ECXP2=$$RJ^XLFSTR(ECXP2,3,0) 104 .;for action code=1, secondary stop code is always "000" 105 .I ECXSEND=1 S ECXP2="000" 106 .;action code of 2 or 3 should not be used, but continue to follow v2t11 logic 107 .I ECXSEND=2 S ECXP1=ECXP2,ECXP2="000" 108 .;for action code=4, need to get national clinic code 109 .I ECXSEND=4 D 110 ..S ECXNC=+$P($G(^ECX(728.44,ECXSC,0)),U,8) 111 ..I ECXNC S ECXNC=$P($G(^ECX(728.441,ECXNC,0)),U),ECXP3=$$RJ^XLFSTR(ECXNC,4,0) 112 .;set data in ^tmp 113 .S ^TMP($J,"ECXS","SC",ECXSC)=ECXP1_U_ECXP2_U_ECXP3_U_ECXSEND 114 Q 115 ; 116 VISIT(ECXDFN,ECXVISIT,ECXVIST,ECXERR) ;get visit specific data 117 ;input ECXVISIT = pointer to file #9000010 118 ; ECXSVC = sc percentage 119 ;output ECXVSIT = data array 120 ; ECXERR = 1 indicates error; otherwise, 0 121 N AO,ARRAY,CM,CNT,CPT,DA,DATE,DA,DIQ,ICD,ICD9,IR,LEN,M,MOD,MST,NUM 122 N PROV,PROVPC,REC,VAL,VISIT,X,Y,PGE 123 S ECXERR=0,VISIT=ECXVISIT 124 S (ECXVIST("AO"),ECXVIST("IR"),ECXVIST("PGE"),ECXVIST("HNC"))="" 125 S (ECXVIST("MST"),ECXVIST("PROV"),ECXVIST("PROV CLASS"))="" 126 S (ECXVIST("PROV NPI"),ECXVIST("SOURCE"))="" 127 F I="P",1,2,3,4 S ECXVIST("ICD9"_I)="" 128 F I=1:1:8 S ECXVIST("CPT"_I)="" 129 D ENCEVENT^PXAPI(VISIT) 130 I $O(^TMP("PXKENC",$J,VISIT,""))']"" K ECXVIST S ECXERR=1 131 Q:ECXERR 132 S DATE=$P($P(^TMP("PXKENC",$J,VISIT,"VST",VISIT,0),U,1),".",1) 133 S ECXVIST("SOURCE")=$P($G(^TMP("PXKENC",$J,VISIT,"VST",VISIT,812)),U,3) 134 ;get icd9 codes upto 5; else use 799.9 135 K ARY S ICD("P")=0,ICD("S")=0,(ARY,REC)="" 136 F S REC=$O(^TMP("PXKENC",$J,VISIT,"POV",REC)) Q:REC="" D 137 .S VAL=^TMP("PXKENC",$J,VISIT,"POV",REC,0) Q:'VAL 138 .I $P(VAL,U,12)="P" D 139 ..S:'$D(ARY("P",+VAL)) CNT=ICD("P")+1,ICD("P",CNT)=+VAL,ICD("P")=CNT 140 ..S ARY("P",+VAL)="" 141 .I $P(VAL,U,12)'="P" D 142 ..S:'$D(ARY("S",+VAL)) CNT=ICD("S")+1,ICD("S",CNT)=+VAL,ICD("S")=CNT 143 ..S ARY("S",+VAL)="" 144 S CNT=0,ECXVIST("ICD9P")=$P($G(^ICD9(+$G(ICD("P",1),0),0)),U) 145 F I=2:1 Q:'$D(ICD("P",I)) D Q:CNT>4 146 .S CNT=CNT+1,ECXVIST("ICD9"_CNT)=$P($G(^ICD9(ICD("P",I),0)),U) 147 I CNT<4 F I=1:1:8 Q:'$D(ICD("S",I)) D Q:CNT>4 148 .I '$D(ARY("P",ICD("S",I))) D 149 ..S CNT=CNT+1,ECXVIST("ICD9"_CNT)=$P($G(^ICD9(ICD("S",I),0)),U) 150 ;get first provider designated as primary 151 ;if no primary, then get first physician provider 152 ;if no physician, then get first provider 153 S (PROV,PROVPC)="" 154 I $O(^TMP("PXKENC",$J,VISIT,"PRV",0)) D 155 .S (REC,VAL)=0 D 156 ..F S REC=$O(^TMP("PXKENC",$J,VISIT,"PRV",REC)) Q:('REC)!(VAL) D 157 ...S:($P(^(REC,0),U,4)="P") VAL=+^(0) 158 ...S PROV=VAL,PROVPC=$$PRVCLASS^ECXUTL(PROV,DATE) 159 .I 'VAL S (REC,VAL)=0 D 160 ..F S REC=$O(^TMP("PXKENC",$J,VISIT,"PRV",REC)) Q:('REC)!(VAL) D 161 ...S (PROV,VAL)=+^(REC,0) 162 ...S PROVPC=$$PRVCLASS^ECXUTL(PROV,DATE) Q:PROVPC="" 163 ...S NUM=$E(PROVPC,2,7) S:(NUM<110000)!(NUM>119999) VAL=0,PROVPC="" 164 .I 'VAL D 165 ..S REC=$O(^TMP("PXKENC",$J,VISIT,"PRV",0)) Q:('REC)!(VAL) 166 ..S VAL=+^(REC,0),PROV=VAL,PROVPC=$$PRVCLASS^ECXUTL(PROV,DATE) 167 .S:PROV]"" PROV="2"_PROV 168 S ECXVIST("PROV")=PROV,ECXVIST("PROV CLASS")=PROVPC 169 S ECXVIST("PROV NPI")="" 170 ;get cpt codes upto 8 & modifiers upto 5 171 S CNT=1,PROV=$E(PROV,2,99) 172 D:$O(^TMP("PXKENC",$J,VISIT,"CPT",0)) 173 .S REC=0 D:PROV]"" 174 ..F S REC=$O(^TMP("PXKENC",$J,VISIT,"CPT",REC)) Q:'REC D Q:CNT>8 175 ...S CPT="",NODE=$G(^TMP("PXKENC",$J,VISIT,"CPT",REC,12)) 176 ...Q:NODE="" 177 ...S NOD1=$S($P(NODE,U,4)=PROV:^TMP("PXKENC",$J,VISIT,"CPT",REC,0),1:"") 178 ...Q:$P(NOD1,U)="" 179 ...S Q="00"_+$P(NOD1,U,16),Q=$S(+Q:$E(Q,$L(Q)-1,$L(Q)),1:"01") 180 ...S CPT=$P(NOD1,U),M=0,MOD="" 181 ...F I=1:1:5 S M=$O(^TMP("PXKENC",$J,VISIT,"CPT",REC,1,M)) Q:'M D 182 ....S MOD=MOD_$S(MOD'="":";",1:"") 183 ....S MOD=MOD_$P(^TMP("PXKENC",$J,VISIT,"CPT",REC,1,M,0),U) 184 ...S ECXVIST("CPT"_CNT)=$$CPT^ECXUTL3(CPT,MOD,Q),CNT=CNT+1 185 ...K ^TMP("PXKENC",$J,VISIT,"CPT",REC) 186 ..Q:CNT>8 187 .Q:CNT>8 S REC=0 188 .F S REC=$O(^TMP("PXKENC",$J,VISIT,"CPT",REC)) Q:'REC D Q:CNT>8 189 ..S CPT="",NOD1=$G(^TMP("PXKENC",$J,VISIT,"CPT",REC,0)) 190 ..Q:$P(NOD1,U)="" 191 ..S Q="00"_+$P(NOD1,U,16),Q=$S(+Q:$E(Q,$L(Q)-1,$L(Q)),1:"01") 192 ..S CPT=$P(NOD1,U),M=0,MOD="" 193 ..F I=1:1:5 S M=$O(^TMP("PXKENC",$J,VISIT,"CPT",REC,1,M)) Q:'M D 194 ...S MOD=MOD_$S(MOD'="":";",1:"") 195 ...S MOD=MOD_$P(^TMP("PXKENC",$J,VISIT,"CPT",REC,1,M,0),U) 196 ..S ECXVIST("CPT"_CNT)=$$CPT^ECXUTL3(CPT,MOD,Q),CNT=CNT+1 197 ..K ^TMP("PXKENC",$J,VISIT,"CPT",REC) 198 ..Q:CNT>8 199 S:ECXVIST("CPT1")="" ECXVIST("CPT1")=9919901 200 ;ao, ir, mst, pge, hnc 201 S (AO,IR,MST,PGE,HNC)="" 202 I $D(^TMP("PXKENC",$J,VISIT,"VST",VISIT,800)) D 203 .S AO=$P(^TMP("PXKENC",$J,VISIT,"VST",VISIT,800),U,2) 204 .S IR=$P(^TMP("PXKENC",$J,VISIT,"VST",VISIT,800),U,3),MST=$P(^(800),U,5) 205 .S PGE=$P(^TMP("PXKENC",$J,VISIT,"VST",VISIT,800),U,4),HNC=$P(^(800),U,6) 206 .S ECXVIST("AO")=$S(AO=0:"N",AO=1:"Y",1:"") 207 .S ECXVIST("IR")=$S(IR=0:"N",IR=1:"Y",1:"") 208 .S ECXVIST("MST")=$S(MST=0:"N",MST=1:"Y",1:"") 209 .S ECXVIST("PGE")=$S(PGE=0:"N",PGE=1:"Y",1:"") 210 .S ECXVIST("HNC")=$S(HNC=0:"N",HNC=1:"Y",1:"") 211 Q 1 ECXSCX1 ;ALB/JAP,BIR/DMA-Clinic Extract Message ; 8/17/06 7:59am 2 ;;3.0;DSS EXTRACTS;**8,28,24,27,29,30,31,33,84,92**;Dec 22, 1997;Build 30 3 EN ;entry point from ecxscx 4 N ECX 5 ;send missing clinic message 6 S ECX=$O(^TMP($J,"ECXS","MISS",0)) D 7 .Q:ECX="" 8 .S XMSUB="MISSING CLINICS in File #728.44",XMDUZ="DSS SYSTEM" 9 .K XMY S XMY("G.DSS-"_ECGRP_"@"_^XMB("NETNAME"))="" 10 .F ECX=1:1:5 S ^TMP($J,"ECXS","MISS",ECX,0)=$P($T(MSG+ECX),";;",2) 11 .S XMTEXT="^TMP($J,""ECXS"",""MISS""," D ^XMD 12 ;send no division message 13 S ECX=$O(^TMP($J,"ECXS","DIV",0)) D 14 .Q:ECX="" 15 .S XMSUB="CLINICS w/o DIVISION Data",XMDUZ="DSS SYSTEM" 16 .K XMY S XMY("G.DSS-"_ECGRP_"@"_^XMB("NETNAME"))="" 17 .F ECX=1:1:5 S ^TMP($J,"ECXS","DIV",ECX,0)=$P($T(MSG2+ECX),";;",2) 18 .S XMTEXT="^TMP($J,""ECXS"",""DIV""," D ^XMD 19 ;cleanup 20 K ^TMP($J,"ECXS") 21 Q 22 MSG ;text for missing clinic 23 ;;The following clinics have not been entered into the CLINIC AND 24 ;;STOP CODES file (#728.44). If any listed clinic is currently 25 ;;active, please use the options 'Create DSS Clinic Stop Code File' 26 ;;and 'Enter/Edit DSS Stop Codes for Clinics' to update this file. 27 ;; 28 ; 29 MSG2 ;text for missing division 30 ;;The following clinics in the HOSPITAL LOCATION file (#44) have not 31 ;;been assigned to a division from the MEDICAL CENTER DIVISION file 32 ;;(#40.8). CLI extract records associated with these clinics have 33 ;;been given a default Division identifier of "1". 34 ;; 35 ; 36 MISS ;load ^tmp if clinic missing from #728.44 37 N DAT,ID,RD 38 S (ID,RD)="" 39 S DAT=$G(^SC(SC,"I")) I DAT]"" S ID=+DAT,RD=$P(DAT,U,2) 40 ;ignore inactive clinics 41 I ID,ID<DT I 'RD!(RD>DT) Q 42 I '$D(^TMP($J,"ECXS","ECXMISS")) S ^TMP($J,"ECXS","ECXMISS")=10 43 S ECXMISS=^TMP($J,"ECXS","ECXMISS") 44 S ^TMP($J,"ECXS","MISS",ECXMISS,0)=$J(SC,6)_" "_$$LJ^XLFSTR($P(^SC(SC,0),U),40)_ECSC_"/"_ECCSC 45 S ^TMP($J,"ECXS","ECXMISS")=ECXMISS+1 46 Q 47 ; 48 NODIV ;load ^tmp if clinic w/o division 49 N DAT,ID,RD 50 S (ID,RD)="" 51 S DAT=$G(^SC(SC,"I")) I DAT]"" S ID=+DAT,RD=$P(DAT,U,2) 52 ;ignore inactive clinics 53 I ID,ID<DT I 'RD!(RD>DT) Q 54 I '$D(^TMP($J,"ECXS","ECXMISS")) S ^TMP($J,"ECXS","ECXMISS")=10 55 S ECXMISS=^TMP($J,"ECXS","ECXMISS") 56 S ^TMP($J,"ECXS","DIV",ECXMISS,0)=$J(SC,6)_" "_$$LJ^XLFSTR($P(^SC(SC,0),U),40) 57 S ^TMP($J,"ECXS","ECXMISS")=ECXMISS+1 58 Q 59 ; 60 FEEDER(ECXSC,ECXSD,ECXP1,ECXP2,ECXP3,ECXSEND,ECXDIV) ;get transmission style and feeder key variables 61 ;feeder key = primary stop code_secondary stop code_length of appointment_national clinic code_noshow indicator 62 ; input 63 ; ECXSC = ien of clinic in file #44 (required) 64 ; ECXSD = start date of extract date range (required) 65 ; ECXP1,ECXP2,ECXP3,ECXSEND passed by reference (required) 66 ; output (passed-by-reference variables) 67 ; ECXP1 = primary stop code 68 ; ECXP2 = secondary stop code 69 ; ECXP3 = field #7 of file #728.44 70 ; ECXSEND = field #5 of file #728.44 71 ; ECXDIV = field #3.5 of file #44 72 N ECSC,ECCSC,ECSD1,ECXNC,ECXMISS,CLIN,SC 73 S (ECXP1,ECXP2)="000",ECXP3="0000" 74 S ECXSEND=1,ECXDIV=0 75 Q:+ECXSC=0 76 ;get needed data from ^tmp 77 I $D(^TMP($J,"ECXS","SC",ECXSC)) D 78 .S CLIN=^TMP($J,"ECXS","SC",ECXSC) 79 .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) 80 .S ECXDIV=+$P($G(^TMP($J,"ECXCL",ECXSC)),U,4) S:ECXDIV=0 ECXDIV=1 81 ;otherwise, set needed data in ^tmp 82 I '$D(^TMP($J,"ECXS","SC",ECXSC)) D 83 .;get division or send no division msg 84 .S ECXDIV=+$P($G(^TMP($J,"ECXCL",ECXSC)),U,4) 85 .I ECXDIV=0 S SC=ECXSC D NODIV S ECXDIV=1 86 .;get other data from file #44 if no #727.44 record; send missing clinic msg 87 .I '$D(^ECX(728.44,ECXSC,0)) D 88 ..S ECSC=+$P($G(^SC(ECXSC,0)),U,7),ECCSC=+$P(^(0),U,18) 89 ..S SC=ECXSC,ECSD1=ECXSD D MISS 90 ..S:ECSC ECXP1=$P($G(^DIC(40.7,ECSC,0)),U,2),ECXP1=$$RJ^XLFSTR(+ECXP1,3,0) 91 .;otherwise get other data from file #728.44 92 .S EC=$G(^ECX(728.44,ECXSC,0)) D 93 ..Q:EC="" 94 ..S ECXSEND=$P(EC,U,6) 95 ..Q:ECXSEND=6 96 ..S ECSC=+$P(EC,U,4),ECCSC=+$P(EC,U,5) 97 ..I 'ECSC S ECSC=+$P(EC,U,2),ECCSC=+$P(EC,U,3) 98 ..I ECSC S ECXP1=$$RJ^XLFSTR(ECSC,3,0),ECXP2=$$RJ^XLFSTR(ECCSC,3,0) 99 ..;if primary stop not valid, use file #44 record 100 ..I 'ECSC S ECSC=+$P($G(^SC(ECXSC,0)),U,7),ECCSC=+$P($G(^(0)),U,18) I ECSC D 101 ...S ECXP1=+$P($G(^DIC(40.7,ECSC,0)),U,2) 102 ...S:ECCSC ECXP2=+$P($G(^DIC(40.7,ECCSC,0)),U,2) 103 ...S ECXP1=$$RJ^XLFSTR(ECXP1,3,0),ECXP2=$$RJ^XLFSTR(ECXP2,3,0) 104 .;for action code=1, secondary stop code is always "000" 105 .I ECXSEND=1 S ECXP2="000" 106 .;action code of 2 or 3 should not be used, but continue to follow v2t11 logic 107 .I ECXSEND=2 S ECXP1=ECXP2,ECXP2="000" 108 .;for action code=4, need to get national clinic code 109 .I ECXSEND=4 D 110 ..S ECXNC=+$P($G(^ECX(728.44,ECXSC,0)),U,8) 111 ..I ECXNC S ECXNC=$P($G(^ECX(728.441,ECXNC,0)),U),ECXP3=$$RJ^XLFSTR(ECXNC,4,0) 112 .;set data in ^tmp 113 .S ^TMP($J,"ECXS","SC",ECXSC)=ECXP1_U_ECXP2_U_ECXP3_U_ECXSEND 114 Q 115 ; 116 VISIT(ECXDFN,ECXVISIT,ECXVIST,ECXERR) ;get visit specific data 117 ;input ECXVISIT = pointer to file #9000010 118 ; ECXSVC = sc percentage 119 ;output ECXVSIT = data array 120 ; ECXERR = 1 indicates error; otherwise, 0 121 N AO,ARRAY,CM,CNT,CPT,DA,DATE,DA,DIQ,ICD,ICD9,IR,LEN,M,MOD,MST,NUM 122 N PROV,PROVPC,REC,VAL,VISIT,X,Y,PGE 123 S ECXERR=0,VISIT=ECXVISIT 124 S (ECXVIST("AO"),ECXVIST("IR"),ECXVIST("PGE"),ECXVIST("HNC"))="" 125 S (ECXVIST("MST"),ECXVIST("PROV"),ECXVIST("PROV CLASS"))="" 126 S (ECXVIST("PROV NPI"),ECXVIST("SOURCE"))="" 127 F I="P",1,2,3,4 S ECXVIST("ICD9"_I)="" 128 F I=1:1:8 S ECXVIST("CPT"_I)="" 129 D ENCEVENT^PXAPI(VISIT) 130 I $O(^TMP("PXKENC",$J,VISIT,""))']"" K ECXVIST S ECXERR=1 131 Q:ECXERR 132 S DATE=$P($P(^TMP("PXKENC",$J,VISIT,"VST",VISIT,0),U,1),".",1) 133 S ECXVIST("SOURCE")=$P($G(^TMP("PXKENC",$J,VISIT,"VST",VISIT,812)),U,3) 134 ;get icd9 codes upto 5; else use 799.9 135 K ARY S ICD("P")=0,ICD("S")=0,(ARY,REC)="" 136 F S REC=$O(^TMP("PXKENC",$J,VISIT,"POV",REC)) Q:REC="" D 137 .S VAL=^TMP("PXKENC",$J,VISIT,"POV",REC,0) Q:'VAL 138 .I $P(VAL,U,12)="P" D 139 ..S:'$D(ARY("P",+VAL)) CNT=ICD("P")+1,ICD("P",CNT)=+VAL,ICD("P")=CNT 140 ..S ARY("P",+VAL)="" 141 .I $P(VAL,U,12)'="P" D 142 ..S:'$D(ARY("S",+VAL)) CNT=ICD("S")+1,ICD("S",CNT)=+VAL,ICD("S")=CNT 143 ..S ARY("S",+VAL)="" 144 S CNT=0,ECXVIST("ICD9P")=$P($G(^ICD9(+$G(ICD("P",1),0),0)),U) 145 F I=2:1 Q:'$D(ICD("P",I)) D Q:CNT>4 146 .S CNT=CNT+1,ECXVIST("ICD9"_CNT)=$P($G(^ICD9(ICD("P",I),0)),U) 147 I CNT<4 F I=1:1:8 Q:'$D(ICD("S",I)) D Q:CNT>4 148 .I '$D(ARY("P",ICD("S",I))) D 149 ..S CNT=CNT+1,ECXVIST("ICD9"_CNT)=$P($G(^ICD9(ICD("S",I),0)),U) 150 S:(ECXVIST("ICD9P")="")&(ECXVIST("ICD91")="") ECXVIST("ICD9P")="799.9" 151 ;get first provider designated as primary 152 ;if no primary, then get first physician provider 153 ;if no physician, then get first provider 154 S (PROV,PROVPC)="" 155 I $O(^TMP("PXKENC",$J,VISIT,"PRV",0)) D 156 .S (REC,VAL)=0 D 157 ..F S REC=$O(^TMP("PXKENC",$J,VISIT,"PRV",REC)) Q:('REC)!(VAL) D 158 ...S:($P(^(REC,0),U,4)="P") VAL=+^(0) 159 ...S PROV=VAL,PROVPC=$$PRVCLASS^ECXUTL(PROV,DATE) 160 .I 'VAL S (REC,VAL)=0 D 161 ..F S REC=$O(^TMP("PXKENC",$J,VISIT,"PRV",REC)) Q:('REC)!(VAL) D 162 ...S (PROV,VAL)=+^(REC,0) 163 ...S PROVPC=$$PRVCLASS^ECXUTL(PROV,DATE) Q:PROVPC="" 164 ...S NUM=$E(PROVPC,2,7) S:(NUM<110000)!(NUM>119999) VAL=0,PROVPC="" 165 .I 'VAL D 166 ..S REC=$O(^TMP("PXKENC",$J,VISIT,"PRV",0)) Q:('REC)!(VAL) 167 ..S VAL=+^(REC,0),PROV=VAL,PROVPC=$$PRVCLASS^ECXUTL(PROV,DATE) 168 .S:PROV]"" PROV="2"_PROV 169 S ECXVIST("PROV")=PROV,ECXVIST("PROV CLASS")=PROVPC 170 S ECXVIST("PROV NPI")="" 171 ;get cpt codes upto 8 & modifiers upto 5 172 S CNT=1,PROV=$E(PROV,2,99) 173 D:$O(^TMP("PXKENC",$J,VISIT,"CPT",0)) 174 .S REC=0 D:PROV]"" 175 ..F S REC=$O(^TMP("PXKENC",$J,VISIT,"CPT",REC)) Q:'REC D Q:CNT>8 176 ...S CPT="",NODE=$G(^TMP("PXKENC",$J,VISIT,"CPT",REC,12)) 177 ...Q:NODE="" 178 ...S NOD1=$S($P(NODE,U,4)=PROV:^TMP("PXKENC",$J,VISIT,"CPT",REC,0),1:"") 179 ...Q:$P(NOD1,U)="" 180 ...S Q="00"_+$P(NOD1,U,16),Q=$S(+Q:$E(Q,$L(Q)-1,$L(Q)),1:"01") 181 ...S CPT=$P(NOD1,U),M=0,MOD="" 182 ...F I=1:1:5 S M=$O(^TMP("PXKENC",$J,VISIT,"CPT",REC,1,M)) Q:'M D 183 ....S MOD=MOD_$S(MOD'="":";",1:"") 184 ....S MOD=MOD_$P(^TMP("PXKENC",$J,VISIT,"CPT",REC,1,M,0),U) 185 ...S ECXVIST("CPT"_CNT)=$$CPT^ECXUTL3(CPT,MOD,Q),CNT=CNT+1 186 ...K ^TMP("PXKENC",$J,VISIT,"CPT",REC) 187 ..Q:CNT>8 188 .Q:CNT>8 S REC=0 189 .F S REC=$O(^TMP("PXKENC",$J,VISIT,"CPT",REC)) Q:'REC D Q:CNT>8 190 ..S CPT="",NOD1=$G(^TMP("PXKENC",$J,VISIT,"CPT",REC,0)) 191 ..Q:$P(NOD1,U)="" 192 ..S Q="00"_+$P(NOD1,U,16),Q=$S(+Q:$E(Q,$L(Q)-1,$L(Q)),1:"01") 193 ..S CPT=$P(NOD1,U),M=0,MOD="" 194 ..F I=1:1:5 S M=$O(^TMP("PXKENC",$J,VISIT,"CPT",REC,1,M)) Q:'M D 195 ...S MOD=MOD_$S(MOD'="":";",1:"") 196 ...S MOD=MOD_$P(^TMP("PXKENC",$J,VISIT,"CPT",REC,1,M,0),U) 197 ..S ECXVIST("CPT"_CNT)=$$CPT^ECXUTL3(CPT,MOD,Q),CNT=CNT+1 198 ..K ^TMP("PXKENC",$J,VISIT,"CPT",REC) 199 ..Q:CNT>8 200 S:ECXVIST("CPT1")="" ECXVIST("CPT1")=9919901 201 ;ao, ir, mst, pge, hnc 202 S (AO,IR,MST,PGE,HNC)="" 203 I $D(^TMP("PXKENC",$J,VISIT,"VST",VISIT,800)) D 204 .S AO=$P(^TMP("PXKENC",$J,VISIT,"VST",VISIT,800),U,2) 205 .S IR=$P(^TMP("PXKENC",$J,VISIT,"VST",VISIT,800),U,3),MST=$P(^(800),U,5) 206 .S PGE=$P(^TMP("PXKENC",$J,VISIT,"VST",VISIT,800),U,4),HNC=$P(^(800),U,6) 207 .S ECXVIST("AO")=$S(AO=0:"N",AO=1:"Y",1:"") 208 .S ECXVIST("IR")=$S(IR=0:"N",IR=1:"Y",1:"") 209 .S ECXVIST("MST")=$S(MST=0:"N",MST=1:"Y",1:"") 210 .S ECXVIST("PGE")=$S(PGE=0:"N",PGE=1:"Y",1:"") 211 .S ECXVIST("HNC")=$S(HNC=0:"N",HNC=1:"Y",1:"") 212 Q -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXSCX2.m
r613 r623 1 ECXSCX2 ;ALB/ESD DSS Clinic Extract Utilities (continued) ; 6/5/2007 2 ;;3.0;DSS EXTRACTS;**39,46,49,71,84,92,105**;Dec 22, 1997;Build 70 3 ; 4 ; 5 INTPAT ;initialize patient variables 6 S (ECXSSN,ECXPNM,ECPTPR,ECCLAS,ECPTNPI,ECASPR,ECCLAS2,ECASNPI,ECXZIP)="" 7 S (ECPTTM,ECXVET,ECXRACE,ECXENRL,ECXMPI,ECXSEX)="" 8 S (ECXDOB,ECXELIG,ECXPST,ECXPLOC,ECXRST,ECXAST,ECXMST,ECXSTATE)="" 9 S (ECXCNTY,ECXATYP,ECXPVST,ECXMTST,ECXEST,ECXECE,ECXHNC)="" 10 Q 11 ; 12 PAT1(ECXDFN,ECXDATE,ECXERR) ;get patient demographic data 13 N ECXPAT,K,OK,X 14 S ECXERR=0 15 S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECXDATE,"."),"1;2;3;4;5",.ECXPAT) 16 I 'OK S ECXERR=1 Q 17 S ECXSSN=ECXPAT("SSN"),ECXPNM=ECXPAT("NAME"),ECXMPI=ECXPAT("MPI") 18 S ECXSEX=ECXPAT("SEX"),ECXDOB=ECXPAT("DOB"),ECXELIG=ECXPAT("ELIG") 19 S ECXVET=ECXPAT("VET"),ECXSVC=ECXPAT("SC%"),ECXRACE=ECXPAT("RACE") 20 S ECXPST=ECXPAT("POW STAT"),ECXPLOC=ECXPAT("POW LOC") 21 S ECXRST=ECXPAT("IR STAT"),ECXAST=ECXPAT("AO STAT") 22 S ECXMST=ECXPAT("MST STAT"),ECXSTATE=ECXPAT("STATE") 23 S ECXCNTY=ECXPAT("COUNTY"),ECXZIP=ECXPAT("ZIP") 24 S ECXENRL=ECXPAT("ENROLL LOC"),ECXMTST=ECXPAT("MEANS") 25 ; changes for 2001 26 S ECXPOS=ECXPAT("POS"),ECXPHI=ECXPAT("PHI") 27 ;- Agent Orange location 28 S ECXAOL=ECXPAT("AOL") 29 ;OEF/OIF data 30 S ECXOEF=ECXPAT("ECXOEF") 31 S ECXOEFDT=ECXPAT("ECXOEFDT") 32 I $$ENROLLM^ECXUTL2(ECXDFN) 33 ; - Head and Neck Cancer Indicator 34 S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) 35 ; - Race and Ethnicity 36 S ECXETH=ECXPAT("ETHNIC") 37 S ECXRC1=ECXPAT("RACE1") 38 ; - Environmental Contaminants 39 S ECXEST=ECXPAT("EC STAT") 40 ;get emergency response indicator (FEMA) 41 S ECXERI=ECXPAT("ERI") 42 Q 43 ; 44 PAT2(ECXDFN,ECXDATE) ;get date specific patient data 45 N K,X 46 ;get primary care data 47 S X=$$PRIMARY^ECXUTL2(ECXDFN,$P(ECXDATE,".")) 48 S ECPTTM=$P(X,U),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4) 49 S ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7) 50 ;get inpatient data 51 S X=$$INP^ECXUTL2(ECXDFN,ECXDATE),ECXA=$P(X,U),ECXTS=$P(X,U,3) 52 S ECXDOM=$P(X,U,10),ECXADMDT=$P(X,U,4) 53 ;- set national patient record flag if exist 54 D NPRF^ECXUTL5 55 Q 56 ; 57 FILE2(ECXFILE,EC7,ECODE) ;file record 58 N DA,DIK,X S X="" 59 F S X=$O(ECODE(X)) Q:X="" S ^ECX(ECXFILE,EC7,X)=ECODE(X) 60 S DA=EC7,DIK="^ECX("_ECXFILE_"," D IX1^DIK K DIK,DA 61 I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 62 Q 63 ; 64 CBOC(MDIV) ;Determine whether patient's facility was CBOC 65 N LOCARR,DIC,DR,DIQ,DA,INST,FTYP 66 S DIC=40.8,DA=MDIV,DR=".07",DIQ(0)="I",DIQ="LOCARR" D EN^DIQ1 67 S INST=$G(LOCARR(40.8,MDIV,.07,"I")) I INST="" Q "" 68 K LOCARR S DIC=4,DA=INST,DR="13",DIQ(0)="I",DIQ="LOCARR" D EN^DIQ1 69 S FTYP=$G(LOCARR(4,INST,13,"I")) I FTYP="" Q "" 70 K LOCARR S DIC=4.1,DA=FTYP,DR=".01",DIQ(0)="I",DIQ="LOCARR" D EN^DIQ1 71 Q $S($G(LOCARR(4.1,FTYP,.01,"I"))="CBOC":"Y",1:"") 1 ECXSCX2 ;ALB/ESD DSS Clinic Extract Utilities (continued) ; 11/2/06 8:59am 2 ;;3.0;DSS EXTRACTS;**39,46,49,71,84,92**;Dec 22, 1997;Build 30 3 ; 4 ; 5 INTPAT ;initialize patient variables 6 S (ECXSSN,ECXPNM,ECPTPR,ECCLAS,ECPTNPI,ECASPR,ECCLAS2,ECASNPI,ECXZIP)="" 7 S (ECPTTM,ECXVET,ECXRACE,ECXENRL,ECXMPI,ECXSEX)="" 8 S (ECXDOB,ECXELIG,ECXPST,ECXPLOC,ECXRST,ECXAST,ECXMST,ECXSTATE)="" 9 S (ECXCNTY,ECXATYP,ECXPVST,ECXMTST,ECXEST,ECXECE,ECXHNC)="" 10 Q 11 ; 12 PAT1(ECXDFN,ECXDATE,ECXERR) ;get patient demographic data 13 N ECXPAT,K,OK,X 14 S ECXERR=0 15 S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECXDATE,"."),"1;2;3;4;5",.ECXPAT) 16 I 'OK S ECXERR=1 Q 17 S ECXSSN=ECXPAT("SSN"),ECXPNM=ECXPAT("NAME"),ECXMPI=ECXPAT("MPI") 18 S ECXSEX=ECXPAT("SEX"),ECXDOB=ECXPAT("DOB"),ECXELIG=ECXPAT("ELIG") 19 S ECXVET=ECXPAT("VET"),ECXSVC=ECXPAT("SC%"),ECXRACE=ECXPAT("RACE") 20 S ECXPST=ECXPAT("POW STAT"),ECXPLOC=ECXPAT("POW LOC") 21 S ECXRST=ECXPAT("IR STAT"),ECXAST=ECXPAT("AO STAT") 22 S ECXMST=ECXPAT("MST STAT"),ECXSTATE=ECXPAT("STATE") 23 S ECXCNTY=ECXPAT("COUNTY"),ECXZIP=ECXPAT("ZIP") 24 S ECXENRL=ECXPAT("ENROLL LOC"),ECXMTST=ECXPAT("MEANS") 25 ; changes for 2001 26 S ECXPOS=ECXPAT("POS"),ECXPHI=ECXPAT("PHI") 27 ;- Agent Orange location 28 S ECXAOL=ECXPAT("AOL") 29 I $$ENROLLM^ECXUTL2(ECXDFN) 30 ; - Head and Neck Cancer Indicator 31 S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) 32 ; - Race and Ethnicity 33 S ECXETH=ECXPAT("ETHNIC") 34 S ECXRC1=ECXPAT("RACE1") 35 ; - Environmental Contaminants 36 S ECXEST=ECXPAT("EC STAT") 37 ;get emergency response indicator (FEMA) 38 S ECXERI=ECXPAT("ERI") 39 Q 40 ; 41 PAT2(ECXDFN,ECXDATE) ;get date specific patient data 42 N K,X 43 ;get primary care data 44 S X=$$PRIMARY^ECXUTL2(ECXDFN,$P(ECXDATE,".")) 45 S ECPTTM=$P(X,U),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4) 46 S ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7) 47 ;get inpatient data 48 S X=$$INP^ECXUTL2(ECXDFN,ECXDATE),ECXA=$P(X,U),ECXTS=$P(X,U,3) 49 S ECXDOM=$P(X,U,10),ECXADMDT=$P(X,U,4) 50 ;- set national patient record flag if exist 51 D NPRF^ECXUTL5 52 Q 53 ; 54 FILE2(ECXFILE,EC7,ECODE) ;file record 55 N DA,DIK,X S X="" 56 F S X=$O(ECODE(X)) Q:X="" S ^ECX(ECXFILE,EC7,X)=ECODE(X) 57 S DA=EC7,DIK="^ECX("_ECXFILE_"," D IX1^DIK K DIK,DA 58 I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 59 Q 60 ; 61 CBOC(MDIV) ;Determine whether patient's facility was CBOC 62 N LOCARR,DIC,DR,DIQ,DA,INST,FTYP 63 S DIC=40.8,DA=MDIV,DR=".07",DIQ(0)="I",DIQ="LOCARR" D EN^DIQ1 64 S INST=$G(LOCARR(40.8,MDIV,.07,"I")) I INST="" Q "" 65 K LOCARR S DIC=4,DA=INST,DR="13",DIQ(0)="I",DIQ="LOCARR" D EN^DIQ1 66 S FTYP=$G(LOCARR(4,INST,13,"I")) I FTYP="" Q "" 67 K LOCARR S DIC=4.1,DA=FTYP,DR=".01",DIQ(0)="I",DIQ="LOCARR" D EN^DIQ1 68 Q $S($G(LOCARR(4.1,FTYP,.01,"I"))="CBOC":"Y",1:"") -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXSCXN.m
r613 r623 1 ECXSCXN ;ALB/JAP Clinic Extract ; 6/5/07 11:55am 2 ;;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 3 ; 4 BEG ;entry point from option 5 D SETUP Q:ECFILE="" D ^ECXTRAC,^ECXKILL 6 Q 7 ; 8 START ;entry point from taskmgr 9 N DIC,EXNUM,I,LOCARR,OUT,P1,P2,P3,PROCESS,SOURCE,STOP,STAT,TOSEND 10 N TIU,X,Y,ECXNPRFI 11 F I=1:1:8 S @("ECXCPT"_I)="" 12 F I=1:1:4 S @("ECXICD9"_I)="" 13 S (OUT,QFLG,ECRN)=0,(ECXICD9P,ECXOBI)="" 14 K ^TMP($J,"ECXS"),^TMP($J,"ECXCL") 15 ;get ien for tiu in file #839.7 16 S DIC="^PX(839.7,",DIC(0)="X",X="TEXT INTEGRATION UTILITIES" 17 D ^DIC S TIU=+Y,ECED=ECED+.3,ECXCLIN=0 K DIC,Y 18 ;get clinic default appt length, type, division 19 F S ECXCLIN=$O(^SC(ECXCLIN)) Q:'ECXCLIN D 20 .K LOCARR S DIC=44,DA=ECXCLIN,DR="2;3.5;1912",DIQ(0)="I",DIQ="LOCARR" 21 .D EN^DIQ1 22 .Q:$G(LOCARR(44,ECXCLIN,2,"I"))'="C" 23 .S ALEN=+$G(LOCARR(44,ECXCLIN,1912,"I")) 24 .S ^TMP($J,"ECXCL",ECXCLIN)=ALEN,ALEN=$$RJ^XLFSTR(ALEN,3,0) 25 .S ^TMP($J,"ECXCL",ECXCLIN)=^TMP($J,"ECXCL",ECXCLIN)_"^"_ALEN_"^"_$G(LOCARR(44,ECXCLIN,2,"I"))_"^"_+$G(LOCARR(44,ECXCLIN,3.5,"I")) 26 .D FEEDER^ECXSCX1(ECXCLIN,ECSD1,.P1,.P2,.P3,.TOSEND,.ECXDIV) 27 .K P1,P2,P3,TOSEND,ECXDIV 28 ;get from file #44 any no-shows & get encounters from #409.68 29 D NOSHOW^ECXSCXN1(ECSD1,ECED),ENCNTR(ECSD1,ECED) 30 ;send missing clinic msg 31 D:$D(^TMP($J,"ECXS")) EN^ECXSCX1 32 K ^TMP($J,"ECXS"),^TMP($J,"ECXCL") 33 Q 34 ; 35 ENCNTR(ECSD1,ECED) ;search file #409.68 for encounter data 36 N CHKOUT,ECD,JJ,K,OUT,PNODE,PP,STAT,STOP,MDIV 37 S ECD=ECSD1 38 F S ECD=$O(^SCE("B",ECD)) Q:('ECD!(ECD>ECED))!(QFLG) S ECXIEN=0 D 39 .F S ECXIEN=$O(^SCE("B",ECD,ECXIEN)) Q:'ECXIEN D Q:QFLG 40 ..Q:'$D(^SCE(ECXIEN,0)) 41 ..D INTPAT^ECXSCX2 K LOCARR S DIC=409.68,DA=ECXIEN 42 ..S DR=".01;.02;.03;.04;.05;.06;.07;.08;.11;.12;.13",DIQ(0)="I",DIQ="LOCARR" 43 ..D EN^DIQ1 44 ..S ECXTI=$P($$FMTE^XLFDT(+$G(LOCARR(409.68,ECXIEN,.01,"I")),1),"@",2) 45 ..S ECXTI=$E(($TR(ECXTI,":","")_"000000"),1,6) 46 ..S:ECXTI="000000" ECXTI="000300" S MDIV=+$G(LOCARR(409.68,ECXIEN,.11,"I")) 47 ..S STOP=+$G(LOCARR(409.68,ECXIEN,.03,"I")) 48 ..S CHKOUT=+$G(LOCARR(409.68,ECXIEN,.07,"I")) 49 ..S PROCESS=+$G(LOCARR(409.68,ECXIEN,.08,"I")) 50 ..S STAT=$G(LOCARR(409.68,ECXIEN,.12,"I")) 51 ..S ECXDFN=+$G(LOCARR(409.68,ECXIEN,.02,"I")) 52 ..Q:(ECXDFN=0)!('CHKOUT) 53 ..S:STAT="" STAT="ZZ" S STAT=";"_STAT_";" 54 ..Q:";3;4;5;6;7;9;10;13;"[STAT 55 ..Q:('STOP)!(PROCESS=4)!(+$G(LOCARR(409.68,ECXIEN,.06,"I"))) 56 ..S ECXDATE=+$G(LOCARR(409.68,ECXIEN,.01,"I")) 57 ..S ECXCLIN=+$G(LOCARR(409.68,ECXIEN,.04,"I")) 58 ..Q:$P($G(^TMP($J,"ECXCL",ECXCLIN)),U,3)'="C" 59 ..S ECXVISIT=+$G(LOCARR(409.68,ECXIEN,.05,"I")) 60 ..S ECXENEL=+$G(LOCARR(409.68,ECXIEN,.13,"I")) 61 ..Q:'ECXVISIT 62 ..S ECXERR=0 63 ..D PAT1^ECXSCX2(ECXDFN,ECXDATE,.ECXERR) Q:ECXERR 64 ..D FEEDER^ECXSCX1(ECXCLIN,ECSD1,.P1,.P2,.P3,.TOSEND,.ECXDIV) 65 ..Q:TOSEND=6 66 ..K LOCARR S DIC=40.7,DA=STOP,DR="1",DIQ(0)="I",DIQ="LOCARR" D EN^DIQ1 67 ..S ECXSTOP=$$RJ^XLFSTR($G(LOCARR(40.7,STOP,1,"I")),3,0) 68 ..;get date specific patient data 69 ..D PAT2^ECXSCX2(ECXDFN,ECXDATE) 70 ..;get national patient record flag if exist 71 ..D NPRF^ECXUTL5 72 ..;get visit specific data 73 ..S ECXERR=0 D VISIT^ECXSCX1(ECXDFN,ECXVISIT,.ECXVIST,.ECXERR) Q:ECXERR 74 ..F I=1:1:8 S @("ECXCPT"_I)=$G(ECXVIST("CPT"_I)) 75 ..S ECXICD9P=$G(ECXVIST("ICD9P")) 76 ..F I=1:1:4 S @("ECXICD9"_I)=$G(ECXVIST("ICD9"_I)) 77 ..S SOURCE=ECXVIST("SOURCE"),ECXAO=ECXVIST("AO"),ECXIR=ECXVIST("IR") 78 ..S ECXMIL=ECXVIST("MST"),ECXPROV=ECXVIST("PROV") 79 ..S ECPRNPI=$$NPI^XUSNPI("Individual_ID",ECXPROV,ECXDATE) 80 ..S:+ECPRNPI'>0 ECPRNPI="" S ECPRNPI=$P(ECPRNPI,U) 81 ..S ECXPROVP=ECXVIST("PROV CLASS"),ECXPROVN=ECXVIST("PROV NPI") 82 ..S ECXECE=ECXVIST("PGE"),ECXHNC=ECXVIST("HNC") 83 ..K LOCARR S DIC=8,DA=ECXENEL,DR="8",DIQ(0)="I",DIQ="LOCARR" D EN^DIQ1 84 ..S ECXENEL=+$G(LOCARR(8,ECXENEL,8,"I")) 85 ..S:ECXENEL ECXENEL=$$ELIG^ECXUTL3(ECXENEL,ECXSVC) 86 ..S ECXCBOC=$S(MDIV'="":$$CBOC^ECXSCX2(.MDIV),1:"") ;is cboc facility? 87 ..;setup feeder key and file in extract records 88 ..S (ECXKEY,ECXDSSD)="" 89 ..;xray (105) or lab (108) 90 ..I (ECXSTOP=105)!(ECXSTOP=108) D Q 91 ...S ECXKEY=ECXSTOP_"00003000000",ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY) 92 ...S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE ;- Don't file rec if no encounter num 93 ..;appointments 94 ..I PROCESS=1 D Q ;get appt length 95 ...S (ALEN,JJ,OUT)=0 96 ...F S JJ=$O(^SC(ECXCLIN,"S",ECXDATE,JJ)) Q:('JJ)!(OUT) S K=0 D 97 ....F S K=$O(^SC(ECXCLIN,"S",ECXDATE,JJ,K)) Q:('K)!(OUT) D 98 .....S ECXOBI=$G(^SC(ECXCLIN,"S",ECXDATE,JJ,K,"OB")),PP=$P($G(^SC(ECXCLIN,"S",ECXDATE,JJ,K,0)),U) 99 .....S:PP=ECXDFN OUT=1,ALEN=$P(^(0),U,2),ALEN=$$RJ^XLFSTR(ALEN,3,0) 100 .....S:+ALEN=0 ALEN=$P($G(^TMP($J,"ECXCL",ECXCLIN)),U,2) 101 ....S ECXSTOP=P1 102 ....S PNODE=$G(^DPT(ECXDFN,"S",ECXDATE,0)),ECXPVST=$P(PNODE,U,7),ECXATYP=$P(PNODE,U,16) ;Get purpose of visit & appt type 103 ....I TOSEND'=3 D 104 .....S ECXKEY=P1_P2_ALEN_P3_"0",ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY) 105 .....S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE 106 ....I TOSEND=3 D 107 .....S ECXKEY=P1_"000"_ALEN_P3_"0",ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY) 108 .....S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE 109 ....I TOSEND=3 D 110 .....S ECXKEY=P2_"000"_ALEN_P3_"0",ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY) 111 .....S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE 112 ..I PROCESS=2 D Q 113 ...S ALEN=0 114 ...I SOURCE=TIU S ALEN=$P($G(^TMP($J,"ECXCL",ECXCLIN)),U,2) 115 ...S:+ALEN=0 ALEN="030" S ECXKEY=P1_P2_ALEN_P3_"0",ECXSTOP=P1 116 ...S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY) 117 ...S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE 118 ..;dispositions 119 ..I PROCESS=3 D Q 120 ...S ECXKEY=ECXSTOP_"47906000000",ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY) 121 ...S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE 122 Q 123 ; 124 FILE ;record setup for file #727.827 125 N STR 126 S ECXPDIV=$$GETDIV^ECXDEPT(ECXDIV) ; Get production division 127 S EC7=$O(^ECX(727.827,999999999),-1),EC7=EC7+1 128 S STR(0)=EC7_U_EC23_U_ECXDIV_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U 129 S STR(0)=STR(0)_$$ECXDATE^ECXUTL(ECXDATE,ECXYM)_U_ECXKEY_U_ECXOBI_U 130 ;convert specialty to PTF Code for transmission 131 N ECXDATA 132 S ECXDATA=$$TSDATA^DGACT(42.4,+ECXTS,.ECXDATA) 133 S ECXTS=$G(ECXDATA(7)) 134 ;done 135 S STR(0)=STR(0)_ECXCLIN_U_ECXTS_U_ECXTI_U_ECPTTM_U_ECPTPR_U_ECCLAS_U 136 S STR(0)=STR(0)_ECXPROV_U_ECXPROVP_U_ECXCPT1_U_ECXCPT2_U_ECXCPT3_U 137 S STR(0)=STR(0)_ECXCPT4_U_ECXCPT5_U 138 S STR(1)=ECXCPT6_U_ECXCPT7_U_ECXCPT8_U_ECXICD9P_U_ECXICD91_U_ECXICD92_U 139 S STR(1)=STR(1)_ECXICD93_U_ECXICD94_U_ECXDOB_U_ECXELIG_U_ECXVET_U 140 S STR(1)=STR(1)_ECXRACE_U_ECXPST_U_ECXPLOC_U_ECXRST_U_ECXIR_U_ECXAST_U 141 S STR(1)=STR(1)_ECXAO_U_ECXMPI_U_ECXDSSD_U_ECXSEX_U_ECXZIP_U 142 S STR(1)=STR(1)_$G(ECXPCPNP)_U_U_ECXENEL_U_ECXMST_U 143 S STR(1)=STR(1)_ECXMIL_U_U_U_ECXENRL_U_ECXSTATE_U 144 S STR(1)=STR(1)_ECXCNTY_U_ECASPR_U_ECCLAS2_U_U_ECXDOM_U_ECXCAT_U 145 S STR(2)=ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXPHI_U_ECXPOS_U_ECXOBS_U_ECXENC_U 146 S STR(2)=STR(2)_ECXAOL_U_ECXPDIV_U_ECXATYP_U_ECXPVST_U_ECXMTST_U 147 S STR(2)=STR(2)_ECXHNCI_U_ECXETH_U_ECXRC1 148 I ECXLOGIC>2003 S STR(2)=STR(2)_U_ECXCBOC 149 I ECXLOGIC>2004 S STR(2)=STR(2)_U_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXNPRFI 150 I ECXLOGIC>2005 S STR(2)=STR(2)_U_ECXEST_U_ECXECE 151 I ECXLOGIC>2006 S STR(2)=STR(2)_U_ECXERI_U_ECXHNC 152 I ECXLOGIC>2007 S STR(2)=STR(2)_U_ECXOEF_U_ECXOEFDT_U_ECASNPI_U_ECPTNPI_U_$G(ECPRNPI) 153 D FILE2^ECXSCX2(727.827,EC7,.STR) 154 S ECRN=ECRN+1,$P(^ECX(727.827,0),U,3)=EC7 155 Q 156 ; 157 SETUP ;set required input for ECXTRAC 158 S ECHEAD="CLI" 159 D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) 160 Q 1 ECXSCXN ;ALB/JAP Clinic Extract ; 4/19/2007 2 ;;3.0;DSS EXTRACTS;**24,27,29,30,31,32,33,39,46,49,52,71,84,92,107**;Dec 22, 1997;Build 9 3 ; 4 BEG ;entry point from option 5 D SETUP Q:ECFILE="" D ^ECXTRAC,^ECXKILL 6 Q 7 ; 8 START ;entry point from taskmgr 9 N DIC,EXNUM,I,LOCARR,OUT,P1,P2,P3,PROCESS,SOURCE,STOP,STAT,TOSEND 10 N TIU,X,Y,ECXNPRFI 11 F I=1:1:8 S @("ECXCPT"_I)="" 12 F I=1:1:4 S @("ECXICD9"_I)="" 13 S (OUT,QFLG,ECRN)=0,(ECXICD9P,ECXOBI)="" 14 K ^TMP($J,"ECXS"),^TMP($J,"ECXCL") 15 ;get ien for tiu in file #839.7 16 S DIC="^PX(839.7,",DIC(0)="X",X="TEXT INTEGRATION UTILITIES" 17 D ^DIC S TIU=+Y,ECED=ECED+.3,ECXCLIN=0 K DIC,Y 18 ;get clinic default appt length, type, division 19 F S ECXCLIN=$O(^SC(ECXCLIN)) Q:'ECXCLIN D 20 .K LOCARR S DIC=44,DA=ECXCLIN,DR="2;3.5;1912",DIQ(0)="I",DIQ="LOCARR" 21 .D EN^DIQ1 22 .Q:$G(LOCARR(44,ECXCLIN,2,"I"))'="C" 23 .S ALEN=+$G(LOCARR(44,ECXCLIN,1912,"I")) 24 .S ^TMP($J,"ECXCL",ECXCLIN)=ALEN,ALEN=$$RJ^XLFSTR(ALEN,3,0) 25 .S ^TMP($J,"ECXCL",ECXCLIN)=^TMP($J,"ECXCL",ECXCLIN)_"^"_ALEN_"^"_$G(LOCARR(44,ECXCLIN,2,"I"))_"^"_+$G(LOCARR(44,ECXCLIN,3.5,"I")) 26 .D FEEDER^ECXSCX1(ECXCLIN,ECSD1,.P1,.P2,.P3,.TOSEND,.ECXDIV) 27 .K P1,P2,P3,TOSEND,ECXDIV 28 ;get from file #44 any no-shows & get encounters from #409.68 29 D NOSHOW^ECXSCXN1(ECSD1,ECED),ENCNTR(ECSD1,ECED) 30 ;send missing clinic msg 31 D:$D(^TMP($J,"ECXS")) EN^ECXSCX1 32 K ^TMP($J,"ECXS"),^TMP($J,"ECXCL") 33 Q 34 ; 35 ENCNTR(ECSD1,ECED) ;search file #409.68 for encounter data 36 N CHKOUT,ECD,JJ,K,OUT,PNODE,PP,STAT,STOP,MDIV 37 S ECD=ECSD1 38 F S ECD=$O(^SCE("B",ECD)) Q:('ECD!(ECD>ECED))!(QFLG) S ECXIEN=0 D 39 .F S ECXIEN=$O(^SCE("B",ECD,ECXIEN)) Q:'ECXIEN D Q:QFLG 40 ..Q:'$D(^SCE(ECXIEN,0)) 41 ..D INTPAT^ECXSCX2 K LOCARR S DIC=409.68,DA=ECXIEN 42 ..S DR=".01;.02;.03;.04;.05;.06;.07;.08;.11;.12;.13",DIQ(0)="I",DIQ="LOCARR" 43 ..D EN^DIQ1 44 ..S ECXTI=$P($$FMTE^XLFDT(+$G(LOCARR(409.68,ECXIEN,.01,"I")),1),"@",2) 45 ..S ECXTI=$E(($TR(ECXTI,":","")_"000000"),1,6) 46 ..S:ECXTI="000000" ECXTI="000300" S MDIV=+$G(LOCARR(409.68,ECXIEN,.11,"I")) 47 ..S STOP=+$G(LOCARR(409.68,ECXIEN,.03,"I")) 48 ..S CHKOUT=+$G(LOCARR(409.68,ECXIEN,.07,"I")) 49 ..S PROCESS=+$G(LOCARR(409.68,ECXIEN,.08,"I")) 50 ..S STAT=$G(LOCARR(409.68,ECXIEN,.12,"I")) 51 ..S ECXDFN=+$G(LOCARR(409.68,ECXIEN,.02,"I")) 52 ..Q:(ECXDFN=0)!('CHKOUT) 53 ..S:STAT="" STAT="ZZ" S STAT=";"_STAT_";" 54 ..Q:";3;4;5;6;7;9;10;13;"[STAT 55 ..Q:('STOP)!(PROCESS=4)!(+$G(LOCARR(409.68,ECXIEN,.06,"I"))) 56 ..S ECXDATE=+$G(LOCARR(409.68,ECXIEN,.01,"I")) 57 ..S ECXCLIN=+$G(LOCARR(409.68,ECXIEN,.04,"I")) 58 ..Q:$P($G(^TMP($J,"ECXCL",ECXCLIN)),U,3)'="C" 59 ..S ECXVISIT=+$G(LOCARR(409.68,ECXIEN,.05,"I")) 60 ..S ECXENEL=+$G(LOCARR(409.68,ECXIEN,.13,"I")) 61 ..Q:'ECXVISIT 62 ..S ECXERR=0 63 ..D PAT1^ECXSCX2(ECXDFN,ECXDATE,.ECXERR) Q:ECXERR 64 ..D FEEDER^ECXSCX1(ECXCLIN,ECSD1,.P1,.P2,.P3,.TOSEND,.ECXDIV) 65 ..Q:TOSEND=6 66 ..K LOCARR S DIC=40.7,DA=STOP,DR="1",DIQ(0)="I",DIQ="LOCARR" D EN^DIQ1 67 ..S ECXSTOP=$$RJ^XLFSTR($G(LOCARR(40.7,STOP,1,"I")),3,0) 68 ..;get date specific patient data 69 ..D PAT2^ECXSCX2(ECXDFN,ECXDATE) 70 ..;get national patient record flag if exist 71 ..D NPRF^ECXUTL5 72 ..;get visit specific data 73 ..S ECXERR=0 D VISIT^ECXSCX1(ECXDFN,ECXVISIT,.ECXVIST,.ECXERR) Q:ECXERR 74 ..F I=1:1:8 S @("ECXCPT"_I)=$G(ECXVIST("CPT"_I)) 75 ..S ECXICD9P=$G(ECXVIST("ICD9P")) 76 ..F I=1:1:4 S @("ECXICD9"_I)=$G(ECXVIST("ICD9"_I)) 77 ..S SOURCE=ECXVIST("SOURCE"),ECXAO=ECXVIST("AO"),ECXIR=ECXVIST("IR") 78 ..S ECXMIL=ECXVIST("MST"),ECXPROV=ECXVIST("PROV") 79 ..S ECXPROVP=ECXVIST("PROV CLASS"),ECXPROVN=ECXVIST("PROV NPI") 80 ..S ECXECE=ECXVIST("PGE"),ECXHNC=ECXVIST("HNC") 81 ..K LOCARR S DIC=8,DA=ECXENEL,DR="8",DIQ(0)="I",DIQ="LOCARR" D EN^DIQ1 82 ..S ECXENEL=+$G(LOCARR(8,ECXENEL,8,"I")) 83 ..S:ECXENEL ECXENEL=$$ELIG^ECXUTL3(ECXENEL,ECXSVC) 84 ..S ECXCBOC=$S(MDIV'="":$$CBOC^ECXSCX2(.MDIV),1:"") ;is cboc facility? 85 ..;setup feeder key and file in extract records 86 ..S (ECXKEY,ECXDSSD)="" 87 ..;xray (105) or lab (108) 88 ..I (ECXSTOP=105)!(ECXSTOP=108) D Q 89 ...S ECXKEY=ECXSTOP_"00003000000",ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY) 90 ...S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE ;- Don't file rec if no encounter num 91 ..;appointments 92 ..I PROCESS=1 D Q ;get appt length 93 ...S (ALEN,JJ,OUT)=0 94 ...F S JJ=$O(^SC(ECXCLIN,"S",ECXDATE,JJ)) Q:('JJ)!(OUT) S K=0 D 95 ....F S K=$O(^SC(ECXCLIN,"S",ECXDATE,JJ,K)) Q:('K)!(OUT) D 96 .....S ECXOBI=$G(^SC(ECXCLIN,"S",ECXDATE,JJ,K,"OB")),PP=$P($G(^SC(ECXCLIN,"S",ECXDATE,JJ,K,0)),U) 97 .....S:PP=ECXDFN OUT=1,ALEN=$P(^(0),U,2),ALEN=$$RJ^XLFSTR(ALEN,3,0) 98 .....S:+ALEN=0 ALEN=$P($G(^TMP($J,"ECXCL",ECXCLIN)),U,2) 99 ....S ECXSTOP=P1 100 ....S PNODE=$G(^DPT(ECXDFN,"S",ECXDATE,0)),ECXPVST=$P(PNODE,U,7),ECXATYP=$P(PNODE,U,16) ;Get purpose of visit & appt type 101 ....I TOSEND'=3 D 102 .....S ECXKEY=P1_P2_ALEN_P3_"0",ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY) 103 .....S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE 104 ....I TOSEND=3 D 105 .....S ECXKEY=P1_"000"_ALEN_P3_"0",ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY) 106 .....S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE 107 ....I TOSEND=3 D 108 .....S ECXKEY=P2_"000"_ALEN_P3_"0",ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY) 109 .....S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE 110 ..I PROCESS=2 D Q 111 ...S ALEN=0 112 ...I SOURCE=TIU S ALEN=$P($G(^TMP($J,"ECXCL",ECXCLIN)),U,2) 113 ...S:+ALEN=0 ALEN="030" S ECXKEY=P1_P2_ALEN_P3_"0",ECXSTOP=P1 114 ...S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY) 115 ...S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE 116 ..;dispositions 117 ..I PROCESS=3 D Q 118 ...S ECXKEY=ECXSTOP_"47906000000",ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY) 119 ...S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE 120 Q 121 ; 122 FILE ;record setup for file #727.827 123 N STR 124 S ECXPDIV=$$GETDIV^ECXDEPT(ECXDIV) ; Get production division 125 S EC7=$O(^ECX(727.827,999999999),-1),EC7=EC7+1 126 S STR(0)=EC7_U_EC23_U_ECXDIV_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U 127 S STR(0)=STR(0)_$$ECXDATE^ECXUTL(ECXDATE,ECXYM)_U_ECXKEY_U_ECXOBI_U 128 ;convert specialty to PTF Code for transmission 129 N ECXDATA 130 S ECXDATA=$$TSDATA^DGACT(42.4,+ECXTS,.ECXDATA) 131 S ECXTS=$G(ECXDATA(7)) 132 ;done 133 S STR(0)=STR(0)_ECXCLIN_U_ECXTS_U_ECXTI_U_ECPTTM_U_ECPTPR_U_ECCLAS_U 134 S STR(0)=STR(0)_ECXPROV_U_ECXPROVP_U_ECXCPT1_U_ECXCPT2_U_ECXCPT3_U 135 S STR(0)=STR(0)_ECXCPT4_U_ECXCPT5_U 136 S STR(1)=ECXCPT6_U_ECXCPT7_U_ECXCPT8_U_ECXICD9P_U_ECXICD91_U_ECXICD92_U 137 S STR(1)=STR(1)_ECXICD93_U_ECXICD94_U_ECXDOB_U_ECXELIG_U_ECXVET_U 138 S STR(1)=STR(1)_ECXRACE_U_ECXPST_U_ECXPLOC_U_ECXRST_U_ECXIR_U_ECXAST_U 139 S STR(1)=STR(1)_ECXAO_U_ECXMPI_U_ECXDSSD_U_ECXSEX_U_ECXZIP_U 140 S STR(1)=STR(1)_$G(ECXPCPNP)_U_$G(ECXNPIPR)_U_ECXENEL_U_ECXMST_U 141 S STR(1)=STR(1)_ECXMIL_U_U_U_ECXENRL_U_ECXSTATE_U 142 S STR(1)=STR(1)_ECXCNTY_U_ECASPR_U_ECCLAS2_U_ECASNPI_U_ECXDOM_U_ECXCAT_U 143 S STR(2)=ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXPHI_U_ECXPOS_U_ECXOBS_U_ECXENC_U 144 S STR(2)=STR(2)_ECXAOL_U_ECXPDIV_U_ECXATYP_U_ECXPVST_U_ECXMTST_U 145 S STR(2)=STR(2)_ECXHNCI_U_ECXETH_U_ECXRC1 146 I ECXLOGIC>2003 S STR(2)=STR(2)_U_ECXCBOC 147 I ECXLOGIC>2004 S STR(2)=STR(2)_U_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXNPRFI 148 I ECXLOGIC>2005 S STR(2)=STR(2)_U_ECXEST_U_ECXECE 149 I ECXLOGIC>2006 S STR(2)=STR(2)_U_ECXERI_U_ECXHNC 150 D FILE2^ECXSCX2(727.827,EC7,.STR) 151 S ECRN=ECRN+1,$P(^ECX(727.827,0),U,3)=EC7 152 Q 153 ; 154 SETUP ;set required input for ECXTRAC 155 S ECHEAD="CLI" 156 D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) 157 Q -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXSCXN1.m
r613 r623 1 ECXSCXN1 ;ALB/JAP Clinic Extract No Shows; 8/28/02 1:11pm ; 9/6/07 3:17pm2 ;;3.0;DSS EXTRACTS;**71,105**;Dec 22, 1997;Build 70 3 NOSHOW(ECXSD,ECXED) 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 ....S ECXCLIN=CLIN,ECXSTOP=P1 34 35 36 37 38 39 40 41 42 43 44 45 46 47 1 ECXSCXN1 ;ALB/JAP Clinic Extract No Shows; 8/28/02 1:11pm ; 10/26/04 10:35am 2 ;;3.0;DSS EXTRACTS;**71**;Dec 22, 1997 3 NOSHOW(ECXSD,ECXED) ;get noshows from file #44 4 ; ECXSD = start date, ECXED = end date 5 N ALEN,CLIN,JDATE,JJ,NODE,NOSHOW,PP,STAT,MDIV 6 S CLIN=0 7 F S CLIN=$O(^TMP($J,"ECXCL",CLIN)) Q:'CLIN D 8 .Q:$P($G(^TMP($J,"ECXCL",CLIN)),U,3)'="C" 9 .S (P1,P2,P3)="" 10 .D FEEDER^ECXSCX1(CLIN,ECXSD,.P1,.P2,.P3,.TOSEND,.ECXDIV) 11 .Q:TOSEND=6 12 .;find appts in date range 13 .S JDATE=ECXSD,(ALEN,NOSHOW)="" 14 .F S JDATE=$O(^SC(CLIN,"S",JDATE)) Q:'JDATE Q:JDATE>ECXED D 15 ..S ECXDATE=JDATE,JJ=0,ECXTI=$P($$FMTE^XLFDT(JDATE,1),"@",2) 16 ..S ECXTI=$E(($TR(ECXTI,":","")_"000000"),1,6) 17 ..S:ECXTI="000000" ECXTI="000300" 18 ..;get noshows only - no data in check-in/check-out node 19 ..F S JJ=$O(^SC(CLIN,"S",JDATE,JJ)) Q:'JJ D 20 ...S K=0 21 ...F S K=$O(^SC(CLIN,"S",JDATE,JJ,K)) Q:'K D 22 ....S PP=$G(^SC(CLIN,"S",JDATE,JJ,K,0)),ECXDFN=$P(PP,U) Q:ECXDFN="" 23 ....S NODE=$G(^DPT(ECXDFN,"S",JDATE,0)),MDIV=$P($G(^SC(CLIN,0)),U,15) 24 ....Q:(NODE="")!($P(NODE,U)'=CLIN) 25 ....S ECXOBI=$G(^SC(CLIN,"S",JDATE,JJ,K,"OB")),STAT=$P(NODE,U,2) 26 ....S NOSHOW=$S(STAT="N":"N",STAT="NA":"N",1:"") 27 ....Q:NOSHOW="" D INTPAT^ECXSCX2 S ECXERR=0 28 ....D PAT1^ECXSCX2(ECXDFN,ECXDATE,.ECXERR) Q:ECXERR 29 ....S ALEN=$P(PP,U,2),ALEN=$$RJ^XLFSTR(ALEN,3,0) 30 ....D PAT2^ECXSCX2(ECXDFN,ECXDATE) 31 ....S ECXPVST=$P(NODE,U,7),ECXATYP=$P(NODE,U,16) ;Get POV & appt type 32 ....S:+ALEN=0 ALEN=$P($G(^TMP($J,"ECXCL",CLIN)),U,2) 33 ....S ECXCLIN=CLIN,ECXSTOP=P1 S:ECXICD9P="" ECXICD9P="799.9" 34 ....S:ECXCPT1="" ECXCPT1="9919901" 35 ....S ECXCBOC=$S(MDIV'="":$$CBOC^ECXSCX2(.MDIV),1:"") 36 ....S (ECXDSSD,ECXENEL,ECXIR,ECXAO,ECXMIL,ECXPROV,ECXPROVP,ECXPROVN)="" 37 ....I TOSEND'=3 D 38 .....S ECXKEY=P1_P2_ALEN_P3_NOSHOW,ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY) 39 .....S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE^ECXSCXN 40 ....I TOSEND=3 D 41 .....S ECXKEY=P1_"000"_ALEN_P3_NOSHOW,ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY) 42 .....S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE^ECXSCXN 43 ....I TOSEND=3 D 44 .....S ECXKEY=P2_"000"_ALEN_P3_NOSHOW,ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY) 45 .....S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE^ECXSCXN 46 ....;create a record for noshow appended ekg. The code was removed for CTX-0604-70970 CLI Extract Problem EXPANDED to NoShows 47 Q -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXSURG.m
r613 r623 1 ECXSURG ;ALB/JA,BIR/DMA,PTD-Surgery Extract for DSS ; 11/20/07 8:13am 2 ;;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 3 BEG ;entry point from option 4 D SETUP I ECFILE="" Q 5 D ^ECXTRAC,^ECXKILL 6 Q 7 ; 8 START ; 9 S QFLG=0,ECED=ECED+.3,ECD=ECSD1 10 F S ECD=$O(^SRF("AC",ECD)),ECD0=0 Q:('ECD)!(ECD>ECED)!(QFLG) D 11 .F S ECD0=$O(^SRF("AC",ECD,ECD0)) Q:'ECD0 D 12 ..I $D(^SRF(ECD0,0)) S EC=^SRF(ECD0,0),ECXDFN=+$P(EC,U),ECXVISIT=$P(EC,U,15) D STUFF Q:QFLG 13 Q 14 ; 15 STUFF ;gather data 16 N J,X,Y,PP,DATA1,DATA2,DATAOP,ARR,ERR,SUB,MOD,ECXNONL,ECXSTOP,TIMEDIF 17 N ECPRO,ECXORCT,ECXPTHA,ECXNPRFI,ECXPA,ECXPAPC,ECSRPC,ECATPC,ECSAPC 18 N ECXCRST,ECXSTCD,ECXCLIN 19 S ECXDATE=ECD,ECXERR=0,ECXQ="" 20 Q:'$$PATDEM^ECXUTL2(ECXDFN,ECXDATE,"1;2;3;5;") 21 I ECXADMDT="" S ECXADD=ECXADMDT 22 I ECXADMDT'="" S ECXADD=$$ECXDATE^ECXUTL(ECXADMDT,ECXYM) 23 S OK=$$PAT^ECXUTL3(ECXDFN,ECXDATE,"1;5",.ECXPAT) 24 I 'OK S ECXERR=1 K ECXPAT Q 25 ;OEF/OIF DATA 26 S ECXOEF=ECXPAT("ECXOEF") 27 S ECXOEFDT=ECXPAT("ECXOEFDT") 28 S EC0=^SRF(ECD0,0) 29 S DATA1=$S($D(^SRF(ECD0,.1)):^(.1),1:"") 30 S DATA2=$S($D(^SRF(ECD0,.2)):^(.2),1:"") 31 S DATAOP=$S($D(^SRO(136,ECD0,0)):^(0),1:"") 32 S ECNO=$G(^SRF(ECD0,"NON")) 33 ;get data 34 S ECSR=$P(DATA1,U,4),(ECATNPI,ECSANPI,ECSRNPI)="",ECAT=$P(DATA1,U,13) 35 S ECSRNPI=$$NPI^XUSNPI("Individual_ID",ECSR,ECXDATE) 36 S:+ECSRNPI'>0 ECSRNPI="" S ECSRNPI=$P(ECSRNPI,U) 37 ;-Time patient in OR room (Nurse Time) 38 S ECXTM=$$ECXTIME^ECXUTL($P(DATA2,U,10)) 39 S ECXDIV=$S($D(^SRF(ECD0,8)):^(8),1:ECINST) 40 N ECXPDIV S ECXPDIV=$$RADDIV^ECXDEPT(ECXDIV) ;Production Division 41 S ECSA=$P($G(^SRF(ECD0,.3)),U,4),ECO=$P(EC0,U,2) 42 S ECSANPI=$$NPI^XUSNPI("Individual_ID",ECSA,ECXDATE) 43 S:+ECSANPI'>0 ECSANPI="" S ECSANPI=$P(ECSANPI,U) 44 ;get principle anesthetist and person class DBIA #103 45 S ECXPA=$P($G(^SRF(ECD0,.3)),U,1) 46 S ECPANPI=$$NPI^XUSNPI("Individual_ID",ECXPA,ECXDATE) 47 S:+ECPANPI'>0 ECPANPI="" S ECPANPI=$P(ECPANPI,U) 48 S ECXPAPC=$$PRVCLASS^ECXUTL(ECXPA,ECXDATE) 49 S ECORTY=$P($G(^SRS(+ECO,2)),U),ECO=$P($G(^SRS(+ECO,0)),U) 50 S ECSS=$P($G(^SRO(137.45,+$P(EC0,U,4),0)),U,2) 51 S ECSS=$$RJ^XLFSTR($P($G(^DIC(45.3,+ECSS,0)),U),3,0) 52 S:ECSS="000" ECSS="999" 53 ;get classification information 54 S (ECXAO,ECXHNC)="" I ECXVISIT'="" D 55 .D VISIT^ECXSCX1(ECXDFN,ECXVISIT,.ECXVIST,.ECXERR) I ECXERR K ECXERR 56 .S ECXAO=$G(ECXVIST("AO")),ECXHNC=$G(ECXVIST("HNC")) 57 ; - Head and Neck Cancer Indicator 58 S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) 59 ;look for non-OR 60 S (ECNT,ECNL,ECXDSSD,ECXNONL,ECXSTOP)="" 61 I $P(ECNO,U)="Y" D 62 .S ECSR=$P(ECNO,U,6),ECAT=$P(ECNO,U,7) 63 .S ECSRNPI=$$NPI^XUSNPI("Individual_ID",ECSR,ECXDATE) 64 .S:+ECSRNPI'>0 ECSRNPI="" S ECSRNPI=$P(ECSRNPI,U) 65 .S ECATNPI=$$NPI^XUSNPI("Individual_ID",ECAT,ECXDATE) 66 .S:+ECATNPI'>0 ECATNPI="" S ECATNPI=$P(ECATNPI,U) 67 .S ECXTM=$$ECXTIME^ECXUTL($P(ECNO,U,4)) 68 .S A1=$P(ECNO,U,5),A2=$P(ECNO,U,4),TIME="##" D:(A1&A2) TIME S ECNT=TIME 69 .S (ECXNONL,ECNL)=+$P(ECNO,U,2),ECNL=$P($G(^ECX(728.44,ECNL,0)),U,9) 70 .S:ECNL="" ECNL="UNKNOWN" 71 .; 72 .;- Get DSS Stop Code to use in encounter number 73 .S ECXSTOP=$P($G(^ECX(728.44,ECXNONL,0)),U,4) 74 ; 75 ;- Get credit stop, stop code and clinic 76 I $$SUR^ECXUTL6(.ECXCRST,.ECXSTCD,.ECXCLIN) 77 ; 78 ;- If surgery cancelled/aborted quit and go to next record 79 S ECCAN=$P($G(^SRF(ECD0,30)),U) 80 I +ECCAN S ECCAN=$$CANC^ECXUTL4(ECNL,$P(DATA2,U,10)) 81 ;on hold for ECXDSSD and ECXDSSP I $P($G(^SRF(ECD0,30)),U) Q 82 ;get service of attending surgeon 83 S ECATSV=$P($G(^DIC(49,+$G(^VA(200,+ECAT,5)),730)),U) 84 ; 85 ;get surgeon, attending and anesthesia super person classes 86 S ECSRPC=$$PRVCLASS^ECXUTL(ECSR,ECXDATE) 87 S ECATPC=$$PRVCLASS^ECXUTL(ECAT,ECXDATE) 88 S ECSAPC=$$PRVCLASS^ECXUTL(ECSA,ECXDATE) 89 ; 90 ;add leading 2s for pointer to 200 91 S:ECAT ECAT="2"_ECAT S:ECSR ECSR="2"_ECSR S:ECSA ECSA="2"_ECSA 92 ;add leading 2 to principle anesthetist IEN 93 S:ECXPA ECXPA="2"_ECXPA 94 ;anesthesia technique 95 S ECANE="",PP="" 96 I $D(^SRF(ECD0,6,0)) S ECXJ=0 D 97 .F S ECXJ=$O(^SRF(ECD0,6,ECXJ)) Q:('ECXJ)!(ECANE]"") D 98 ..S PP=$P($G(^(ECXJ,0)),U,3) S:PP="Y" ECANE=$P(^(0),U,1) 99 .I ECANE="" S ECXJ=$O(^SRF(ECD0,6,0)) I ECXJ S ECANE=$P(^SRF(ECD0,6,ECXJ,0),U,1) 100 ;get primary procedure 101 ;ecode0=p^cpt code^^patient time^operation time^anesthesia time 102 S ECPT=+$P(DATAOP,U,2),ECXCMOD="" 103 K ARR,ERR D FIELD^DID(130,28,,"LABEL","ARR","ERR") I $D(ARR("LABEL")) D 104 .K ARR,ERR D FIELD^DID(130,28,,"GLOBAL SUBSCRIPT LOCATION","ARR","ERR") 105 .Q:$D(ERR("DIERR")) 106 .S SUB=$P(ARR("GLOBAL SUBSCRIPT LOCATION"),";"),MOD=0 107 .F S MOD=$O(^SRF(ECD0,SUB,MOD)) Q:MOD'>0 D 108 ..S ECXCMOD=ECXCMOD_$P(^(MOD,0),U)_";" 109 S ECXCPT=$$CPT^ECXUTL3(ECPT,ECXCMOD) 110 S ECODE0="P"_U_U ;ECPT_U 111 F J="10,12","2,3","1,4" D 112 .N ECNTIME,ECSTIME,ECATIME 113 .S A2=$P(DATA2,U,$P(J,",")),A1=$P(DATA2,U,$P(J,",",2)),TIME="##" 114 .I (A1&A2)&(+J=10) D TIME S ECNTIME=TIME 115 .I (A1&A2)&(+J=1) D TIME S ECATIME=TIME 116 .I (A1&A2)&(+J=2) D 117 ..; 118 ..;-Operation Time (Surgeon Time) 119 ..;-Get time diff (in secs) & set to .5 if < 7.5 minutes (rounds to 1) 120 ..S TIMEDIF=$$FMDIFF^XLFDT(A1,A2,2)/900 121 ..S TIMEDIF=$S(TIMEDIF>0&(TIMEDIF<.5):.5,1:TIMEDIF) 122 ..S TIME=$TR($J(TIMEDIF,4,0)," ") 123 ..S:TIME<0 TIME="###" 124 ..S:TIME ECSTIME=TIME 125 .S ECODE0=ECODE0_U_TIME K TIME 126 ; -Recovery Room Time 127 S ECRR="" 128 I $D(^SRF(ECD0,1.1)) D 129 .S A1=$P(^(1.1),U,8),A2=$P(^(1.1),U,7),TIME="##" D:(A1&A2) TIME 130 .S ECRR=TIME K TIME 131 I ECNL]"" S $P(ECODE0,U,5)=ECNT 132 ; 133 ; -OR Clean Time in 15 min increments DBIA #103 134 S ECXORCT=($$FMDIFF^XLFDT($P($G(DATA2),U,14),$P($G(DATA2),U,13),2)/60)/15 135 ; -If no OR clean time recorded set it to 2 136 I ECXORCT'>0 S ECXORCT=2 137 ; 138 ; -PT in hold area time in 15 min increments DBIA #103 139 I $P($G(DATA2),U,10),$P($G(DATA2),U,15) D 140 .S ECXPTHA=($$FMDIFF^XLFDT($P($G(DATA2),U,10),$P($G(DATA2),U,15),2)/60)/15 141 .S CON=$P($G(^SRF(ECD0,"CON")),U) 142 .I CON S ECXPTHA=ECXPTHA/2 143 .S ECXPTHA=$TR($J(ECXPTHA,3,0)," ") 144 ; -If hold time is =<0 set it to "" 145 S:$G(ECXPTHA)'>0 ECXPTHA="" 146 ; 147 ;- Observation Patient Indicator (yes/no) 148 S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECNL) 149 ; 150 ;- set national patient record flag if exist 151 D NPRF^ECXUTL5 152 ; 153 ;- If no encounter number don't file record 154 S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXSTOP,ECSS) Q:ECXENC="" 155 ; 156 ;- Get postop diagnosis codes 157 I $$SURPODX^ECXUTL6(.ECXPODX,.ECXPODX1,.ECXPODX2,.ECXPODX3,.ECXPODX4,.ECXPODX5) 158 ; 159 D FILE^ECXSURG1 160 ;get secondary procedures 161 ;ecode0=s^cpt code 162 S ECXJ=0 163 F S ECXJ=$O(^SRO(136,ECD0,3,ECXJ)) Q:'ECXJ I $D(^(ECXJ,0)),$D(^(0)),$P(^(0),"^")]"" D 164 .;S ECPT=$P(^SRF(ECD0,13,ECXJ,2),U),ECXCMOD="" 165 .S ECPT=$P(^SRO(136,ECD0,3,ECXJ,0),U),ECXMOD="" 166 .S ECPT=$P(^(0),"^"),ECXCMOD="" 167 .K ARR,ERR 168 .D FIELD^DID(130.16,4,,"LABEL","ARR","ERR") I $D(ARR("LABEL")) D 169 ..K ARR,ERR 170 ..D FIELD^DID(130.16,4,,"GLOBAL SUBSCRIPT LOCATION","ARR","ERR") 171 ..Q:$D(ERR("DIERR")) 172 ..S SUB=$P(ARR("GLOBAL SUBSCRIPT LOCATION"),";"),MOD=0 173 ..F S MOD=$O(^SRF(ECD0,13,ECXJ,SUB,MOD)) Q:MOD'>0 S ECXCMOD=ECXCMOD_$P(^(MOD,0),U)_";" 174 .S ECXCPT=$$CPT^ECXUTL3(ECPT,ECXCMOD) 175 .S ECODE0="S"_U ;_ECPT 176 .D FILE^ECXSURG1 177 ;get prostheses 178 ;ecode0=i^^^^^^prosthesis^old qty field (null) 179 S ECXJ=0 180 F S ECXJ=$O(^SRF(ECD0,1,ECXJ)) Q:'ECXJ I $D(^(ECXJ,0)) D 181 .S ECXP=+^SRF(ECD0,1,ECXJ,0),ECXQ=$P($G(^(1)),U,2) S:'ECXQ ECXQ=1 182 .S ECODE0="I"_U_U_U_U_U_U_ECXP_U_U 183 .D FILE^ECXSURG1 184 Q 185 ; 186 ; 187 TIME ; given date/time get increment 188 ;A1=later, A2=earlier, TIME=difference 189 N CON,TIMEDIF 190 S CON=$P($G(^SRF(ECD0,"CON")),U) 191 ; 192 ;-Get time diff (in secs) & set to .5 if < 7.5 minutes (rounds to 1) 193 S TIMEDIF=$$FMDIFF^XLFDT(A1,A2,2)/900 194 S TIMEDIF=$S(TIMEDIF>0&(TIMEDIF<.5):.5,1:TIMEDIF) 195 I 'CON D 196 .S TIME=$J($TR($J(TIMEDIF,4,0)," "),2,1) 197 .S:TIME>"99.0" TIME="99.0" 198 I CON D 199 .S TIME=$J(($TR($J(TIMEDIF,4,0)," ")/2),2,1) 200 .S:TIME>"99.5" TIME="99.5" 201 S:TIME<0 TIME="###" 202 Q 203 ; 204 SETUP ;Set required input for ECXTRAC 205 S ECHEAD="SUR" 206 D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) 207 Q 208 ; 209 QUE ; entry point for the background requeuing handled by ECXTAUTO 210 D SETUP,QUE^ECXTAUTO,^ECXKILL Q 1 ECXSURG ;ALB/JA,BIR/DMA,PTD-Surgery Extract for DSS ; 11/2/06 9:00am 2 ;;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 3 BEG ;entry point from option 4 D SETUP I ECFILE="" Q 5 D ^ECXTRAC,^ECXKILL 6 Q 7 ; 8 START ; 9 S QFLG=0,ECED=ECED+.3,ECD=ECSD1 10 F S ECD=$O(^SRF("AC",ECD)),ECD0=0 Q:('ECD)!(ECD>ECED)!(QFLG) D 11 .F S ECD0=$O(^SRF("AC",ECD,ECD0)) Q:'ECD0 D 12 ..I $D(^SRF(ECD0,0)) S EC=^SRF(ECD0,0),ECXDFN=+$P(EC,U),ECXVISIT=$P(EC,U,15) D STUFF Q:QFLG 13 Q 14 ; 15 STUFF ;gather data 16 N J,X,Y,PP,DATA1,DATA2,DATAOP,ARR,ERR,SUB,MOD,ECXNONL,ECXSTOP,TIMEDIF 17 N ECPRO,ECXORCT,ECXPTHA,ECXNPRFI,ECXPA,ECXPAPC,ECSRPC,ECATPC,ECSAPC 18 S ECXDATE=ECD,ECXERR=0,ECXQ="" 19 Q:'$$PATDEM^ECXUTL2(ECXDFN,ECXDATE,"1;2;3;5;") 20 I ECXADMDT="" S ECXADD=ECXADMDT 21 I ECXADMDT'="" S ECXADD=$$ECXDATE^ECXUTL(ECXADMDT,ECXYM) 22 S EC0=^SRF(ECD0,0) 23 S DATA1=$S($D(^SRF(ECD0,.1)):^(.1),1:"") 24 S DATA2=$S($D(^SRF(ECD0,.2)):^(.2),1:"") 25 ;S DATAOP=$S($D(^SRF(ECD0,"OP")):^("OP"),1:"") 26 S DATAOP=$S($D(^SRO(136,ECD0,0)):^(0),1:"") 27 S ECNO=$G(^SRF(ECD0,"NON")) 28 ;get data 29 S ECSR=$P(DATA1,U,4),(ECATNPI,ECSANPI,ECSRNPI)="",ECAT=$P(DATA1,U,13) 30 ;-Time patient in OR room (Nurse Time) 31 S ECXTM=$$ECXTIME^ECXUTL($P(DATA2,U,10)) 32 S ECXDIV=$S($D(^SRF(ECD0,8)):^(8),1:ECINST) 33 N ECXPDIV S ECXPDIV=$$RADDIV^ECXDEPT(ECXDIV) ;Production Division 34 S ECSA=$P($G(^SRF(ECD0,.3)),U,4),ECO=$P(EC0,U,2) 35 ;get principle anesthetist and person class DBIA #103 36 S ECXPA=$P($G(^SRF(ECD0,.3)),U,1) 37 S ECXPAPC=$$PRVCLASS^ECXUTL(ECXPA,ECXDATE) 38 S ECORTY=$P($G(^SRS(+ECO,2)),U),ECO=$P($G(^SRS(+ECO,0)),U) 39 S ECSS=$P($G(^SRO(137.45,+$P(EC0,U,4),0)),U,2) 40 S ECSS=$$RJ^XLFSTR($P($G(^DIC(45.3,+ECSS,0)),U),3,0) 41 S:ECSS="000" ECSS="999" 42 ;get classification information 43 S (ECXAO,ECXHNC)="" I ECXVISIT'="" D 44 .D VISIT^ECXSCX1(ECXDFN,ECXVISIT,.ECXVIST,.ECXERR) I ECXERR K ECXERR 45 .S ECXAO=$G(ECXVIST("AO")),ECXHNC=$G(ECXVIST("HNC")) 46 ; - Head and Neck Cancer Indicator 47 S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) 48 ;look for non-OR 49 S (ECNT,ECNL,ECXDSSD,ECXNONL,ECXSTOP)="" 50 I $P(ECNO,U)="Y" D 51 .S ECSR=$P(ECNO,U,6),ECAT=$P(ECNO,U,7) 52 .S ECXTM=$$ECXTIME^ECXUTL($P(ECNO,U,4)) 53 .S A1=$P(ECNO,U,5),A2=$P(ECNO,U,4),TIME="##" D:(A1&A2) TIME S ECNT=TIME 54 .S (ECXNONL,ECNL)=+$P(ECNO,U,2),ECNL=$P($G(^ECX(728.44,ECNL,0)),U,9) 55 .S:ECNL="" ECNL="UNKNOWN" 56 .; 57 .;- Get DSS Stop Code to use in encounter number 58 .S ECXSTOP=$P($G(^ECX(728.44,ECXNONL,0)),U,4) 59 ; 60 ;- If surgery cancelled/aborted quit and go to next record 61 S ECCAN=$P($G(^SRF(ECD0,30)),U) 62 I +ECCAN S ECCAN=$$CANC^ECXUTL4(ECNL,$P(DATA2,U,10)) 63 ;on hold for ECXDSSD and ECXDSSP I $P($G(^SRF(ECD0,30)),U) Q 64 ;get service of attending surgeon 65 S ECATSV=$P($G(^DIC(49,+$G(^VA(200,+ECAT,5)),730)),U) 66 ; 67 ;get surgeon, attending and anesthesia super person classes 68 S ECSRPC=$$PRVCLASS^ECXUTL(ECSR,ECXDATE) 69 S ECATPC=$$PRVCLASS^ECXUTL(ECAT,ECXDATE) 70 S ECSAPC=$$PRVCLASS^ECXUTL(ECSA,ECXDATE) 71 ; 72 ;add leading 2s for pointer to 200 73 S:ECAT ECAT="2"_ECAT S:ECSR ECSR="2"_ECSR S:ECSA ECSA="2"_ECSA 74 ;add leading 2 to principle anesthetist IEN 75 S:ECXPA ECXPA="2"_ECXPA 76 ;anesthesia technique 77 S ECANE="",PP="" 78 I $D(^SRF(ECD0,6,0)) S ECXJ=0 D 79 .F S ECXJ=$O(^SRF(ECD0,6,ECXJ)) Q:('ECXJ)!(ECANE]"") D 80 ..S PP=$P($G(^(ECXJ,0)),U,3) S:PP="Y" ECANE=$P(^(0),U,1) 81 .I ECANE="" S ECXJ=$O(^SRF(ECD0,6,0)) I ECXJ S ECANE=$P(^SRF(ECD0,6,ECXJ,0),U,1) 82 ;get primary procedure 83 ;ecode0=p^cpt code^^patient time^operation time^anesthesia time 84 S ECPT=+$P(DATAOP,U,2),ECXCMOD="" 85 K ARR,ERR D FIELD^DID(130,28,,"LABEL","ARR","ERR") I $D(ARR("LABEL")) D 86 .K ARR,ERR D FIELD^DID(130,28,,"GLOBAL SUBSCRIPT LOCATION","ARR","ERR") 87 .Q:$D(ERR("DIERR")) 88 .S SUB=$P(ARR("GLOBAL SUBSCRIPT LOCATION"),";"),MOD=0 89 .F S MOD=$O(^SRF(ECD0,SUB,MOD)) Q:MOD'>0 D 90 ..S ECXCMOD=ECXCMOD_$P(^(MOD,0),U)_";" 91 S ECXCPT=$$CPT^ECXUTL3(ECPT,ECXCMOD) 92 S ECODE0="P"_U_U ;ECPT_U 93 F J="10,12","2,3","1,4" D 94 .N ECNTIME,ECSTIME,ECATIME 95 .S A2=$P(DATA2,U,$P(J,",")),A1=$P(DATA2,U,$P(J,",",2)),TIME="##" 96 .I (A1&A2)&(+J=10) D TIME S ECNTIME=TIME 97 .I (A1&A2)&(+J=1) D TIME S ECATIME=TIME 98 .I (A1&A2)&(+J=2) D 99 ..; 100 ..;-Operation Time (Surgeon Time) 101 ..;-Get time diff (in secs) & set to .5 if < 7.5 minutes (rounds to 1) 102 ..S TIMEDIF=$$FMDIFF^XLFDT(A1,A2,2)/900 103 ..S TIMEDIF=$S(TIMEDIF>0&(TIMEDIF<.5):.5,1:TIMEDIF) 104 ..S TIME=$TR($J(TIMEDIF,4,0)," ") 105 ..S:TIME<0 TIME="###" 106 ..S:TIME ECSTIME=TIME 107 .S ECODE0=ECODE0_U_TIME K TIME 108 ; -Recovery Room Time 109 S ECRR="" 110 I $D(^SRF(ECD0,1.1)) D 111 .S A1=$P(^(1.1),U,8),A2=$P(^(1.1),U,7),TIME="##" D:(A1&A2) TIME 112 .S ECRR=TIME K TIME 113 I ECNL]"" S $P(ECODE0,U,5)=ECNT 114 ; 115 ; -OR Clean Time in 15 min increments DBIA #103 116 S ECXORCT=($$FMDIFF^XLFDT($P($G(DATA2),U,14),$P($G(DATA2),U,13),2)/60)/15 117 ; -If no OR clean time recorded set it to 2 118 I ECXORCT'>0 S ECXORCT=2 119 ; 120 ; -PT in hold area time in 15 min increments DBIA #103 121 I $P($G(DATA2),U,10),$P($G(DATA2),U,15) D 122 .S ECXPTHA=($$FMDIFF^XLFDT($P($G(DATA2),U,10),$P($G(DATA2),U,15),2)/60)/15 123 .S CON=$P($G(^SRF(ECD0,"CON")),U) 124 .I CON S ECXPTHA=ECXPTHA/2 125 .S ECXPTHA=$TR($J(ECXPTHA,3,0)," ") 126 ; -If hold time is =<0 set it to "" 127 S:$G(ECXPTHA)'>0 ECXPTHA="" 128 ; 129 ;- Observation Patient Indicator (yes/no) 130 S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECNL) 131 ; 132 ;- set national patient record flag if exist 133 D NPRF^ECXUTL5 134 ; 135 ;- If no encounter number don't file record 136 S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXSTOP,ECSS) Q:ECXENC="" 137 ; 138 D FILE 139 ;get secondary procedures 140 ;ecode0=s^cpt code 141 S ECXJ=0 142 ;F S ECXJ=$O(^SRF(ECD0,13,ECXJ)) Q:'ECXJ I $D(^(ECXJ,0)),$D(^(2)),$P(^(2),U)]"" D 143 F S ECXJ=$O(^SRO(136,ECD0,3,ECXJ)) Q:'ECXJ I $D(^(ECXJ,0)),$D(^(0)),$P(^(0),"^")]"" D 144 .;S ECPT=$P(^SRF(ECD0,13,ECXJ,2),U),ECXCMOD="" 145 . S ECPT=$P(^SRO(136,ECD0,3,ECXJ,0),"^"),ECXCMOD="" 146 .K ARR,ERR 147 .D FIELD^DID(130.16,4,,"LABEL","ARR","ERR") I $D(ARR("LABEL")) D 148 ..K ARR,ERR 149 ..D FIELD^DID(130.16,4,,"GLOBAL SUBSCRIPT LOCATION","ARR","ERR") 150 ..Q:$D(ERR("DIERR")) 151 ..S SUB=$P(ARR("GLOBAL SUBSCRIPT LOCATION"),";"),MOD=0 152 ..F S MOD=$O(^SRF(ECD0,13,ECXJ,SUB,MOD)) Q:MOD'>0 S ECXCMOD=ECXCMOD_$P(^(MOD,0),U)_";" 153 .S ECXCPT=$$CPT^ECXUTL3(ECPT,ECXCMOD) 154 .S ECODE0="S"_U ;_ECPT 155 .D FILE 156 ;get prostheses 157 ;ecode0=i^^^^^^prosthesis^old qty field (null) 158 S ECXJ=0 159 F S ECXJ=$O(^SRF(ECD0,1,ECXJ)) Q:'ECXJ I $D(^(ECXJ,0)) D 160 .S ECXP=+^SRF(ECD0,1,ECXJ,0),ECXQ=$P($G(^(1)),U,2) S:'ECXQ ECXQ=1 161 .S ECODE0="I"_U_U_U_U_U_U_ECXP_U_U 162 .D FILE 163 Q 164 ; 165 FILE ;file record 166 ;node0 167 ;division^dfn^ssn^name^in/out (ECXA)^day^case #^ 168 ;surg specialty^or room #^ 169 ;surgeon^attending^anesthesia supervisor^anesthesia technique^ 170 ;primary/secondary/prostheses^cpt^^pt time^op time^anes time^ 171 ;prostheses^qty^^ 172 ;movement number^treating specialty^cancel/abort (ECCAN)^time^or type^ 173 ;attending's service^non-or dss id^recovery room time^^ 174 ;primary care team^primary care provider^admission date 175 ;node1 176 ;mpi^dss dept ECXDSSD^surgeon npi^attending npi^anes supervisor npi^ 177 ;pc provider npi^pc prov person class^ 178 ;assoc pc provider^assoc pc prov person class^assoc pc prov npi^ 179 ;cpt&modifiers ECXCPT^dom ECXDOM^enrollment category ECXCAT^ 180 ;enrollment status ECXSTAT^enrollment priority ECXPRIOR^ 181 ;period of service ECXPOS^purple heart indicator ECXPHI^ 182 ;observ pat ind ECXOBS^encounter num ECXENC^ao loc ECXAOL^ 183 ;production division ECXPDIV^head & neck canc ind ECXHNCI^ 184 ;ethnicity ECXETH^race1 ECXRC1^new quantity ECXQ^ 185 ;^user enrollee ECXUESTA^patient type ECXPTYPE^combat vet elig 186 ;ECXCVE^combat vet elig end date ECXCVEDT^enc cv eligible ECXCVENC 187 ;or clean time ECXORCT^time pt in hold area ECXPTHA^national patient 188 ;record flag ECXNPRFI^princ anesthetist ECXPA^surgeon per class ECSRPC 189 ;node2 190 ;atten surgeon per class ECATPC^anesthesia super person class ECSAPC^ 191 ;princ anesthetist PC ECXPAPC^emergency response indicator(FEMA) ECXERI^ 192 ;agent orange indic ECXAO^head/neck cancer ECXHNC 193 ; 194 N DA,DIK,STR 195 S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 196 S ECODE=EC7_U_EC23_U_ECXDIV_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U 197 S ECODE=ECODE_$$ECXDATE^ECXUTL(ECXDATE,ECXYM)_U_ECD0_U_ECSS_U_ECO_U 198 S ECODE=ECODE_ECSR_U_ECAT_U_ECSA_U_ECANE_U_ECODE0_U 199 S STR=ECXMN_U_ECXTS_U_$S(ECCAN'="":ECCAN,1:"")_U_ECXTM_U_ECORTY_U 200 S STR=STR_ECATSV_U_ECNL_U_ECRR_U_U_ECPTTM_U_ECPTPR_U_ECXADD_U 201 S $P(ECODE,U,26,38)=STR 202 S ECODE1=ECXMPI_U_ECXDSSD_U_ECSRNPI_U_ECATNPI_U_ECSANPI_U_ECPTNPI_U 203 S ECODE1=ECODE1_ECCLAS_U_ECASPR_U_ECCLAS2_U_ECASNPI_U_ECXCPT_U_ECXDOM_U 204 S ECODE1=ECODE1_ECXCAT_U_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXPOS_U_ECXPHI_U 205 S ECODE1=ECODE1_ECXOBS_U_ECXENC_U_ECXAOL_U_ECXPDIV_U_ECXHNCI_U 206 S ECODE1=ECODE1_ECXETH_U_ECXRC1_U_ECXQ_U 207 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 208 I ECXLOGIC>2005 S ECODE1=ECODE1_U_ECXPA_U_ECSRPC_U,ECODE2=ECATPC_U_ECSAPC_U_ECXPAPC 209 I ECXLOGIC>2006 S ECODE2=ECODE2_U_ECXERI_U_ECXAO_U_ECXHNC 210 S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,^ECX(ECFILE,EC7,2)=ECODE2,ECRN=ECRN+1 211 S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA 212 I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 213 ; 214 TIME ; given date/time get increment 215 ;A1=later, A2=earlier, TIME=difference 216 N CON,TIMEDIF 217 S CON=$P($G(^SRF(ECD0,"CON")),U) 218 ; 219 ;-Get time diff (in secs) & set to .5 if < 7.5 minutes (rounds to 1) 220 S TIMEDIF=$$FMDIFF^XLFDT(A1,A2,2)/900 221 S TIMEDIF=$S(TIMEDIF>0&(TIMEDIF<.5):.5,1:TIMEDIF) 222 I 'CON D 223 .S TIME=$J($TR($J(TIMEDIF,4,0)," "),2,1) 224 .S:TIME>"99.0" TIME="99.0" 225 I CON D 226 .S TIME=$J(($TR($J(TIMEDIF,4,0)," ")/2),2,1) 227 .S:TIME>"99.5" TIME="99.5" 228 S:TIME<0 TIME="###" 229 Q 230 ; 231 SETUP ;Set required input for ECXTRAC 232 S ECHEAD="SUR" 233 D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) 234 Q 235 ; 236 QUE ; entry point for the background requeuing handled by ECXTAUTO 237 D SETUP,QUE^ECXTAUTO,^ECXKILL Q -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXTRAC.m
r613 r623 1 ECXTRAC ;ALB/GTS,JAP,BIR/DMA,CML-Package Extracts for DSS ; 7/29/07 12:51pm 2 ;;3.0;DSS EXTRACTS;**9,8,14,24,30,33,49,84,105**;Dec 22, 1997;Build 70 3 ;Date range, queuing and message sending for package extracts 4 ;Input 5 ; ECPACK printed name of package (e.g. Lab, Prescriptions) 6 ; ECNODE in file 728 where last date is stored 7 ; ECPIECE piece of node where last date is stored 8 ; ECRTN in the form of START^ROUTINE 9 ; ECGRP name of local mail group to receive summary message 10 ; (MUST BE 1 TO 5 UPPER CASE ALPHA - NO SPACES) 11 ; ECFILE file number of the local editing file 12 ; ECXLOGIC Fiscal year extract logic to use (optional) 13 ; ECXDATES StartDate^EndDate^DoNotUpdate728 (optional) 14 ;Generates 15 ; EC23=2nd and 3rd piece of zero node in local editing file 16 ; =YYMM of end date^pointer to 727 17 ; ECXLOGIC=Fiscal year extract logic to use 18 ; 19 EN ;entry point 20 N OUT,CHKFLG 21 I '$D(ECNODE) S ECNODE=7 22 I '$D(ECHEAD) S ECHEAD=" " 23 I $P($G(^ECX(728,1,ECNODE+.1)),U,ECPIECE)]"" D Q 24 .W !!,$C(7),ECPACK," extract is already scheduled to run",!! 25 .D PAUSE 26 W @IOF,!,"Extract ",ECPACK," Information for DSS",!! 27 S:'$D(ECINST) ECINST=+$P(^ECX(728,1,0),U) 28 S ECXINST=ECINST 29 K ECXDIC S DA=ECINST,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99" 30 D EN^DIQ1 S ECINST=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC 31 ;* get last date for all extracts except prosthetics 32 I ECGRP'="PRO" D 33 .S ECLDT=$S($D(^ECX(728,1,ECNODE)):$P(^(ECNODE),U,ECPIECE),1:2610624) 34 .S:ECLDT="" ECLDT=2610624 35 ;* get last date for prosthetics 36 I ECGRP="PRO" D 37 .N ECXDA1 38 .S ECXDA1=$O(^ECX(728,0)) 39 .I $D(^ECX(728,ECXDA1,1,ECXINST,0)) D 40 ..S ECLDT=$P(^ECX(728,ECXDA1,1,ECXINST,0),U,2) 41 .I '$D(^ECX(728,ECXDA1,1,ECXINST,0)) D 42 ..S DA(1)=ECXDA1 43 ..S DIC(0)="L" K ECXDD 44 ..D FIELD^DID(728,59,,"SPECIFIER","ECXDD") 45 ..S DIC("P")=ECXDD("SPECIFIER") K ECXDD 46 ..S DIC="^ECX(728,"_DA(1)_",1,",X=ECXINST,DINUM=X 47 ..K DD,DO D FILE^DICN 48 ..K DIC,X,DINUM,Y,DA 49 ..S ECLDT=2610624 50 S X=$G(ECXDATES) S ECSD=$P(X,"^",1),ECED=$P(X,"^",2) 51 S OUT=0 52 I (ECSD="")!(ECED="") F S (ECED,ECSD)="" D Q:OUT 53 .K %DT S %DT="AEX",%DT("A")="Starting with Date: " D ^%DT 54 .I Y<0 S OUT=1 Q 55 .S ECSD=Y 56 .K %DT S %DT="AEX",%DT("A")="Ending with Date: " D ^%DT 57 .I Y<0 S OUT=1 Q 58 .I Y<ECSD D Q 59 ..W !!,"The ending date cannot be earlier than the starting date." 60 ..W !,"Please try again.",!! 61 .I $E(Y,1,5)'=$E(ECSD,1,5) D Q 62 ..W !!,"Beginning and ending dates must be in the same month and year." 63 ..W !,"Please try again.",!! 64 .S ECED=Y 65 .I ECLDT'<ECSD D Q 66 ..W !!,"The ",ECPACK," information has already been extracted through ",$$FMTE^XLFDT(ECLDT),"." 67 ..W !,"Please enter a new date range.",!! 68 .S OUT=1 69 I ECED]"",ECSD]"" D QUE 70 Q 71 ; 72 QUE ;queue extract 73 N CHKFLG 74 ;if extract is ivp (i.e., file=727.819) and data in the intermediate file use new format 75 I ECFILE=727.819 D Q:CHKFLG 76 .S CHKFLG=0 77 .S X="PSIVSTAT" X ^%ZOSF("TEST") I '$T Q 78 .I '$D(^ECX(728.113,"A")) S CHKFLG=1 D NOIVP Q 79 .S DATE=$O(^ECX(728.113,"A",ECED+1),-1) I DATE<ECSD S CHKFLG=1 D NOIVP Q 80 .D CHK^ECXDIVIV Q:CHKFLG 81 .D CHK2 82 .S ECRTN="START^ECXPIVDN",ECVER=7 83 I '$D(ECNODE) S ECNODE=7 84 I '$D(ECHEAD) S ECHEAD="" 85 S ECSDN=$$FMTE^XLFDT(ECSD),ECEDN=$$FMTE^XLFDT(ECED),ECSD1=ECSD-.1 86 K ZTSAVE 87 F X="ECINST","ECED","ECSD","ECSD1","ECEDN","ECSDN" S ZTSAVE(X)="" 88 F X="ECPACK","ECPIECE","ECRTN","ECGRP","ECNODE" S ZTSAVE(X)="" 89 F X="ECFILE","ECHEAD","ECVER","ECINST","ECXINST" S ZTSAVE(X)="" 90 F X="ECXLOGIC","ECXDATES" S ZTSAVE(X)="" 91 S ZTDESC=ECPACK_" EXTRACT: "_ECSDN_" TO "_ECEDN,ZTRTN="START^ECXTRAC",ZTIO="" 92 D ^%ZTLOAD 93 I $D(ZTSK) D 94 .S $P(^ECX(728,1,ECNODE+.1),U,ECPIECE)="R" 95 .W !,"Request queued as Task #",ZTSK,".",! 96 .D PAUSE 97 Q 98 ; 99 NOIVP ;cannot generate ivp message 100 W !!,?5,"There does not appear to be any data in the IV EXTRACT DATA" 101 W !,?5,"file (#728.113) for the selected date range." 102 W !!,?5,"The IVP extract cannot be generated." 103 D PAUSE 104 Q 105 ; 106 START ; entry when queued 107 S QFLG=0 108 L +^ECX(727,0) S EC=$P(^ECX(727,0),U,3)+1,$P(^(0),U,3,4)=EC_U_EC L -^ECX(727,0) 109 S ^ECX(727,EC,0)=EC_U_DT_U_ECPACK_U_ECSD_U_$E(ECED,1,7)_U_U_DUZ 110 S ^ECX(727,EC,"HEAD")=ECHEAD 111 S:ECFILE=727.816 ECFILE=727.827 S ^ECX(727,EC,"FILE")=ECFILE 112 S ^ECX(727,EC,"GRP")=ECGRP 113 I $G(ECXLOGIC)="" S ECXLOGIC=$$FISCAL^ECXUTL1(ECSD) 114 S ^ECX(727,EC,"VER")=$G(ECVER)_"^"_ECXLOGIC 115 S ^ECX(727,EC,"DIV")=ECXINST 116 S DA=EC,DIK="^ECX(727," D IX^DIK K DIK,DA 117 S ECRN=0,ECXYM=$$ECXYM^ECXUTL(ECED),EC23=ECXYM_U_EC 118 S ECXSTART=$P($$HTE^XLFDT($H),":",1,2),ECXNOW=$H 119 ;do specific extract 120 D @ECRTN 121 ;if task gets stop request, set ztstop and quit 122 I QFLG D Q 123 .S $P(^ECX(728,1,ECNODE+.1),U,ECPIECE)="",ZTSTOP=1 124 .D QKILL 125 .D QMSG 126 .D ^ECXKILL 127 ;Set last date for extract 128 I '$P($G(ECXDATES),"^",3) D 129 .;* set last date for all extracts except prosthetics 130 .I ECGRP'="PRO" S $P(^ECX(728,1,ECNODE),U,ECPIECE)=$P(ECED,".") Q 131 .;* set last date for prosthetics 132 .N ECXDA1 133 .S ECXDA1=$O(^ECX(728,0)) 134 .S $P(^ECX(728,ECXDA1,1,ECXINST,0),U,2)=$P(ECED,".") 135 S TIME=$P($$HTE^XLFDT($H),":",1,2) 136 S $P(^ECX(727,$P(EC23,U,2),0),U,6)=ECRN 137 ;set piece 3 and 4 of the zero node 138 S ECLAST=$O(^ECX(ECFILE,99999999),-1),ECTOTAL=$P(^ECX(ECFILE,0),U,4)+ECRN,$P(^(0),U,3,4)=ECLAST_U_ECTOTAL K ECLAST,ECTOTAL 139 D MSG 140 S $P(^ECX(728,1,ECNODE+.1),U,ECPIECE)="" 141 I $D(ZTQUEUED) S ZTREQ="@" 142 Q 143 ; 144 MSG ; send message to mail group 'DSS-ECGRP' 145 S XMSUB=ECINST_" - "_ECPACK_" EXTRACT FOR DSS",XMDUZ="DSS SYSTEM" 146 K XMY S XMY("G.DSS-"_ECGRP_"@"_^XMB("NETNAME"))="" 147 S ECMSG(1,0)="The DSS-"_ECPACK_" extract (#"_$P(EC23,U,2)_") for "_ECSDN 148 S ECMSG(2,0)="through "_ECEDN_" was begun on "_$P(ECXSTART,"@")_" at "_$P(ECXSTART,"@",2) 149 S ECMSG(3,0)="and completed on "_$P(TIME,"@")_" at "_$P(TIME,"@",2)_"." 150 S ECMSG(4,0)=" " 151 S ECMSG(5,0)="A total of "_ECRN_" records were written." 152 S ECMSG(6,0)=" " 153 S ECMSG(7,0)="Extract time was [HH:MM:SS] "_$$HDIFF^XLFDT($H,ECXNOW,3) 154 S ECMSG(8,0)=" " 155 S X=$E(ECXLOGIC,5) S X=$S((X="")!(X=" "):"",1:"revision "_X_" of ") 156 S ECMSG(9,0)="The data was extracted using "_X_"fiscal year "_$E(ECXLOGIC,1,4)_" logic." 157 S ECMSG(10,0)=" " 158 S XMTEXT="ECMSG(" 159 D ^XMD 160 Q 161 ; 162 QMSG ; send abort message to mail group 'DSS-ECGRP' 163 S XMSUB=ECINST_" - "_ECPACK_" EXTRACT FOR DSS",XMDUZ="DSS SYSTEM" 164 K XMY S XMY("G.DSS-"_ECGRP_"@"_^XMB("NETNAME"))="" 165 S ECMSG(1,0)="The DSS-"_ECPACK_" extract (#"_$P(EC23,U,2)_") for "_ECSDN 166 S ECMSG(2,0)="through "_ECEDN_" was begun on "_$P(ECXSTART,"@")_" at "_$P(ECXSTART,"@",2)_"." 167 S ECMSG(3,0)=" " 168 S ECMSG(4,0)="A user stop request was received by Taskmanager which caused processing" 169 S ECMSG(5,0)="to terminate before completion. Any records which may have been created" 170 S ECMSG(6,0)="in file #"_ECFILE_" for this extract have been deleted." 171 S ECMSG(7,0)=" " 172 S XMTEXT="ECMSG(" 173 D ^XMD 174 Q 175 ; 176 QKILL ;delete records created for any extract stopped at user request 177 N ECX,FILE,IEN,DA,DIK 178 S FILE="^ECX("_ECFILE_"," 179 S ECX=$P(EC23,U,2) 180 F S IEN=$O(^ECX(ECFILE,999999999),-1) Q:($P(^ECX(ECFILE,IEN,0),U,3)'=ECX) D 181 .S DIK=FILE,DA=IEN D ^DIK 182 Q 183 ; 184 CHK2 ;iv extract check - all active iv rooms to have a division 185 S EC=0 186 D ALL^PSJ59P5(,"??","ECXIV") 187 F S EC=$O(^TMP($J,"ECXIV",EC)) Q:'EC I '^(EC,19) D I CHKFLG D EXIT Q 188 .S CHKFLG=$S($G(^TMP($J,"ECXIV",EC,19)):1,$G(^(19))>DT:1,1:0) 189 .I CHKFLG D 190 ..W !!,"All active IV Rooms in the IV Room file (#59.5) must have a ""DIVISION""",!,"assigned to run this extract!" 191 ..W !!,"This information can be entered using the DSS Extract Manager's Maintenance ",!,"option ""Enter/Edit IV Room Division""." 192 ..D PAUSE 193 EXIT K ^TMP($J,"ECXIV") 194 Q 195 ; 196 PAUSE ;pause screen 197 N DIR,X,Y 198 S OUT=0 199 I $E(IOST)="C" D 200 .S SS=22-$Y F JJ=1:1:SS W ! 201 .S DIR(0)="E" W ! D ^DIR K DIR 202 I 'Y S OUT=1 203 W !! 204 Q 1 ECXTRAC ;ALB/GTS,JAP,BIR/DMA,CML-Package Extracts for DSS ; 5/9/05 10:39am 2 ;;3.0;DSS EXTRACTS;**9,8,14,24,30,33,49,84**;Dec 22, 1997 3 ;Date range, queuing and message sending for package extracts 4 ;Input 5 ; ECPACK printed name of package (e.g. Lab, Prescriptions) 6 ; ECNODE in file 728 where last date is stored 7 ; ECPIECE piece of node where last date is stored 8 ; ECRTN in the form of START^ROUTINE 9 ; ECGRP name of local mail group to receive summary message 10 ; (MUST BE 1 TO 5 UPPER CASE ALPHA - NO SPACES) 11 ; ECFILE file number of the local editing file 12 ; ECXLOGIC Fiscal year extract logic to use (optional) 13 ; ECXDATES StartDate^EndDate^DoNotUpdate728 (optional) 14 ;Generates 15 ; EC23=2nd and 3rd piece of zero node in local editing file 16 ; =YYMM of end date^pointer to 727 17 ; ECXLOGIC=Fiscal year extract logic to use 18 ; 19 EN ;entry point 20 N OUT,CHKFLG 21 I '$D(ECNODE) S ECNODE=7 22 I '$D(ECHEAD) S ECHEAD=" " 23 I $P($G(^ECX(728,1,ECNODE+.1)),U,ECPIECE)]"" D Q 24 .W !!,$C(7),ECPACK," extract is already scheduled to run",!! 25 .D PAUSE 26 W @IOF,!,"Extract ",ECPACK," Information for DSS",!! 27 S:'$D(ECINST) ECINST=+$P(^ECX(728,1,0),U) 28 S ECXINST=ECINST 29 K ECXDIC S DA=ECINST,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99" 30 D EN^DIQ1 S ECINST=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC 31 ;* get last date for all extracts except prosthetics 32 I ECGRP'="PRO" D 33 .S ECLDT=$S($D(^ECX(728,1,ECNODE)):$P(^(ECNODE),U,ECPIECE),1:2610624) 34 .S:ECLDT="" ECLDT=2610624 35 ;* get last date for prosthetics 36 I ECGRP="PRO" D 37 .N ECXDA1 38 .S ECXDA1=$O(^ECX(728,0)) 39 .I $D(^ECX(728,ECXDA1,1,ECXINST,0)) D 40 ..S ECLDT=$P(^ECX(728,ECXDA1,1,ECXINST,0),U,2) 41 .I '$D(^ECX(728,ECXDA1,1,ECXINST,0)) D 42 ..S DA(1)=ECXDA1 43 ..S DIC(0)="L" K ECXDD 44 ..D FIELD^DID(728,59,,"SPECIFIER","ECXDD") 45 ..S DIC("P")=ECXDD("SPECIFIER") K ECXDD 46 ..S DIC="^ECX(728,"_DA(1)_",1,",X=ECXINST,DINUM=X 47 ..K DD,DO D FILE^DICN 48 ..K DIC,X,DINUM,Y,DA 49 ..S ECLDT=2610624 50 S X=$G(ECXDATES) S ECSD=$P(X,"^",1),ECED=$P(X,"^",2) 51 S OUT=0 52 I (ECSD="")!(ECED="") F S (ECED,ECSD)="" D Q:OUT 53 .K %DT S %DT="AEX",%DT("A")="Starting with Date: " D ^%DT 54 .I Y<0 S OUT=1 Q 55 .S ECSD=Y 56 .K %DT S %DT="AEX",%DT("A")="Ending with Date: " D ^%DT 57 .I Y<0 S OUT=1 Q 58 .I Y<ECSD D Q 59 ..W !!,"The ending date cannot be earlier than the starting date." 60 ..W !,"Please try again.",!! 61 .I $E(Y,1,5)'=$E(ECSD,1,5) D Q 62 ..W !!,"Beginning and ending dates must be in the same month and year." 63 ..W !,"Please try again.",!! 64 .S ECED=Y 65 .I ECLDT'<ECSD D Q 66 ..W !!,"The ",ECPACK," information has already been extracted through ",$$FMTE^XLFDT(ECLDT),"." 67 ..W !,"Please enter a new date range.",!! 68 .S OUT=1 69 I ECED]"",ECSD]"" D QUE 70 Q 71 ; 72 QUE ;queue extract 73 N CHKFLG 74 ;if extract is ivp (i.e., file=727.819) and data in the intermediate file use new format 75 I ECFILE=727.819 D Q:CHKFLG 76 .S CHKFLG=0 77 .S X="PSIVSTAT" X ^%ZOSF("TEST") I '$T Q 78 .I '$D(^ECX(728.113,"A")) S CHKFLG=1 D NOIVP Q 79 .S DATE=$O(^ECX(728.113,"A",ECED+1),-1) I DATE<ECSD S CHKFLG=1 D NOIVP Q 80 .D CHK^ECXDIVIV Q:CHKFLG 81 .D CHK2 82 .S ECRTN="START^ECXPIVDN",ECVER=7 83 I '$D(ECNODE) S ECNODE=7 84 I '$D(ECHEAD) S ECHEAD="" 85 S ECSDN=$$FMTE^XLFDT(ECSD),ECEDN=$$FMTE^XLFDT(ECED),ECSD1=ECSD-.1 86 K ZTSAVE 87 F X="ECINST","ECED","ECSD","ECSD1","ECEDN","ECSDN" S ZTSAVE(X)="" 88 F X="ECPACK","ECPIECE","ECRTN","ECGRP","ECNODE" S ZTSAVE(X)="" 89 F X="ECFILE","ECHEAD","ECVER","ECINST","ECXINST" S ZTSAVE(X)="" 90 F X="ECXLOGIC","ECXDATES" S ZTSAVE(X)="" 91 S ZTDESC=ECPACK_" EXTRACT: "_ECSDN_" TO "_ECEDN,ZTRTN="START^ECXTRAC",ZTIO="" 92 D ^%ZTLOAD 93 I $D(ZTSK) D 94 .S $P(^ECX(728,1,ECNODE+.1),U,ECPIECE)="R" 95 .W !,"Request queued as Task #",ZTSK,".",! 96 .D PAUSE 97 Q 98 ; 99 NOIVP ;cannot generate ivp message 100 W !!,?5,"There does not appear to be any data in the IV EXTRACT DATA" 101 W !,?5,"file (#728.113) for the selected date range." 102 W !!,?5,"The IVP extract cannot be generated." 103 D PAUSE 104 Q 105 ; 106 START ; entry when queued 107 S QFLG=0 108 L +^ECX(727,0) S EC=$P(^ECX(727,0),U,3)+1,$P(^(0),U,3,4)=EC_U_EC L -^ECX(727,0) 109 S ^ECX(727,EC,0)=EC_U_DT_U_ECPACK_U_ECSD_U_$E(ECED,1,7)_U_U_DUZ 110 S ^ECX(727,EC,"HEAD")=ECHEAD 111 S:ECFILE=727.816 ECFILE=727.827 S ^ECX(727,EC,"FILE")=ECFILE 112 S ^ECX(727,EC,"GRP")=ECGRP 113 I $G(ECXLOGIC)="" S ECXLOGIC=$$FISCAL^ECXUTL1(ECSD) 114 S ^ECX(727,EC,"VER")=$G(ECVER)_"^"_ECXLOGIC 115 S ^ECX(727,EC,"DIV")=ECXINST 116 S DA=EC,DIK="^ECX(727," D IX^DIK K DIK,DA 117 S ECRN=0,ECXYM=$$ECXYM^ECXUTL(ECED),EC23=ECXYM_U_EC 118 S ECXSTART=$P($$HTE^XLFDT($H),":",1,2),ECXNOW=$H 119 ;do specific extract 120 D @ECRTN 121 ;if task gets stop request, set ztstop and quit 122 I QFLG D Q 123 .S $P(^ECX(728,1,ECNODE+.1),U,ECPIECE)="",ZTSTOP=1 124 .D QKILL 125 .D QMSG 126 .D ^ECXKILL 127 ;Set last date for extract 128 I '$P($G(ECXDATES),"^",3) D 129 .;* set last date for all extracts except prosthetics 130 .I ECGRP'="PRO" S $P(^ECX(728,1,ECNODE),U,ECPIECE)=$P(ECED,".") Q 131 .;* set last date for prosthetics 132 .N ECXDA1 133 .S ECXDA1=$O(^ECX(728,0)) 134 .S $P(^ECX(728,ECXDA1,1,ECXINST,0),U,2)=$P(ECED,".") 135 S TIME=$P($$HTE^XLFDT($H),":",1,2) 136 S $P(^ECX(727,$P(EC23,U,2),0),U,6)=ECRN 137 ;set piece 3 and 4 of the zero node 138 S ECLAST=$O(^ECX(ECFILE,99999999),-1),ECTOTAL=$P(^ECX(ECFILE,0),U,4)+ECRN,$P(^(0),U,3,4)=ECLAST_U_ECTOTAL K ECLAST,ECTOTAL 139 D MSG 140 S $P(^ECX(728,1,ECNODE+.1),U,ECPIECE)="" 141 I $D(ZTQUEUED) S ZTREQ="@" 142 Q 143 ; 144 MSG ; send message to mail group 'DSS-ECGRP' 145 S XMSUB=ECINST_" - "_ECPACK_" EXTRACT FOR DSS",XMDUZ="DSS SYSTEM" 146 K XMY S XMY("G.DSS-"_ECGRP_"@"_^XMB("NETNAME"))="" 147 S ECMSG(1,0)="The DSS-"_ECPACK_" extract (#"_$P(EC23,U,2)_") for "_ECSDN 148 S ECMSG(2,0)="through "_ECEDN_" was begun on "_$P(ECXSTART,"@")_" at "_$P(ECXSTART,"@",2) 149 S ECMSG(3,0)="and completed on "_$P(TIME,"@")_" at "_$P(TIME,"@",2)_"." 150 S ECMSG(4,0)=" " 151 S ECMSG(5,0)="A total of "_ECRN_" records were written." 152 S ECMSG(6,0)=" " 153 S ECMSG(7,0)="Extract time was [HH:MM:SS] "_$$HDIFF^XLFDT($H,ECXNOW,3) 154 S ECMSG(8,0)=" " 155 S X=$E(ECXLOGIC,5) S X=$S((X="")!(X=" "):"",1:"revision "_X_" of ") 156 S ECMSG(9,0)="The data was extracted using "_X_"fiscal year "_$E(ECXLOGIC,1,4)_" logic." 157 S ECMSG(10,0)=" " 158 S XMTEXT="ECMSG(" 159 D ^XMD 160 Q 161 ; 162 QMSG ; send abort message to mail group 'DSS-ECGRP' 163 S XMSUB=ECINST_" - "_ECPACK_" EXTRACT FOR DSS",XMDUZ="DSS SYSTEM" 164 K XMY S XMY("G.DSS-"_ECGRP_"@"_^XMB("NETNAME"))="" 165 S ECMSG(1,0)="The DSS-"_ECPACK_" extract (#"_$P(EC23,U,2)_") for "_ECSDN 166 S ECMSG(2,0)="through "_ECEDN_" was begun on "_$P(ECXSTART,"@")_" at "_$P(ECXSTART,"@",2)_"." 167 S ECMSG(3,0)=" " 168 S ECMSG(4,0)="A user stop request was received by Taskmanager which caused processing" 169 S ECMSG(5,0)="to terminate before completion. Any records which may have been created" 170 S ECMSG(6,0)="in file #"_ECFILE_" for this extract have been deleted." 171 S ECMSG(7,0)=" " 172 S XMTEXT="ECMSG(" 173 D ^XMD 174 Q 175 ; 176 QKILL ;delete records created for any extract stopped at user request 177 N ECX,FILE,IEN,DA,DIK 178 S FILE="^ECX("_ECFILE_"," 179 S ECX=$P(EC23,U,2) 180 F S IEN=$O(^ECX(ECFILE,999999999),-1) Q:($P(^ECX(ECFILE,IEN,0),U,3)'=ECX) D 181 .S DIK=FILE,DA=IEN D ^DIK 182 Q 183 ; 184 CHK2 ;iv extract check - all active iv rooms to have a division 185 S EC=0 186 F S EC=$O(^PS(59.5,EC)) Q:'EC I '$P(^PS(59.5,EC,0),U,4) D Q:CHKFLG 187 .S CHKFLG=$S('$G(^PS(59.5,EC,"I")):1,$G(^PS(59.5,EC,"I"))>DT:1,1:0) 188 .I CHKFLG D 189 ..W !!,"All active IV Rooms in the IV Room file (#59.5) must have a ""DIVISION""",!,"assigned to run this extract!" 190 ..W !!,"This information can be entered using the DSS Extract Manager's Maintenance ",!,"option ""Enter/Edit IV Room Division""." 191 ..D PAUSE 192 Q 193 ; 194 PAUSE ;pause screen 195 N DIR,X,Y 196 S OUT=0 197 I $E(IOST)="C" D 198 .S SS=22-$Y F JJ=1:1:SS W ! 199 .S DIR(0)="E" W ! D ^DIR K DIR 200 I 'Y S OUT=1 201 W !! 202 Q -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXTREX.m
r613 r623 1 ECXTREX ;BPFO/JRP - Queue DSS Fiscal Year Specific Extract;8-AUG-2003 ; 6/11/07 12:46pm2 ;;3.0;DSS EXTRACTS;**49,71,84,92,105**;Dec 22, 1997;Build 703 4 EN 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 F X=2003,2004,2005,2006,2007,2008D74 75 76 77 78 79 80 81 82 83 PAUSE 84 85 86 87 88 89 1 ECXTREX ;BPFO/JRP - Queue DSS Fiscal Year Specific Extract;8-AUG-2003 ; 11/2/06 9:02am 2 ;;3.0;DSS EXTRACTS;**49,71,84,92**;Dec 22, 1997;Build 30 3 ; 4 EN ;Main entry point 5 W @IOF 6 N DIC,X,Y,DTOUT,DUOUT 7 W !,"****************************************************************" 8 W !,"* *" 9 W !,"* This option should be used with caution as it allows for the *" 10 W !,"* extraction of data using specified fiscal year logic. This *" 11 W !,"* gives the ability to extract fiscal year 200x data using *" 12 W !,"* fiscal year 200(x+1) logic and vice versa. Note that data *" 13 W !,"* extracted via this method may or may not be transmittable to *" 14 W !,"* the DSS production queue at the Austin Automation Center. *" 15 W !,"* *" 16 W !,"*--------------------------------------------------------------*" 17 W !,"* *" 18 W !,"* Note that this option does not update the last date used for *" 19 W !,"* the given extraction. It also does not verify that the time *" 20 W !,"* frame selected is after the last date used for the extract. *" 21 W !,"* *" 22 W !,"****************************************************************" 23 W !! 24 ;Pick extract to queue 25 S DIC="^ECX(727.1," 26 S DIC(0)="AEQMZ" 27 S DIC("A")="Select DSS Extract to queue: " 28 S DIC("S")="I ('$P(^(0),U,12))&($P(^(0),U,8)'="""")&($G(^(7))'[""Inactive"")" 29 S DIC("W")="W ""("",$P(^(0),U,8),"")""" 30 D ^DIC 31 I ($D(DUOUT))!($D(DTOUT))!(Y<1) Q 32 N ECXRTN,ECXDA 33 S ECXDA=+Y 34 ;Get extract specific routine name 35 S ECXRTN=$G(^ECX(727.1,ECXDA,"ROU")) 36 I ECXRTN="" D Q 37 .W !!,"Selected extract is not correctly defined in the EXTRACT" 38 .W !,"DEFINITIONS file (#727.1). The ROUTINE field (#4) does not" 39 .W !,"have a value in it." 40 .W ! 41 .D PAUSE 42 ;Get time frame for extract 43 N STRTDT,ENDDT,DIR,DIRUT,DIROUT,OUT,ECXDATES 44 S OUT=0 F S (STRTDT,ENDDT)="" D Q:OUT 45 .;Get start date (must be in past) 46 .S DIR(0)="DOA" 47 .S $P(DIR(0),"^",2)=":"_DT_":AEXP" 48 .S DIR("A")="Starting with Date: " 49 .D ^DIR 50 .I $D(DIROUT)!$D(DIRUT)!(Y="") S (STRTDT,ENDDT)="" S OUT=1 Q 51 .S STRTDT=Y 52 .K DIR 53 .;Get end date (must be in same month; must be in past) 54 .S DIR(0)="DOA" 55 .S X=$E(STRTDT,1,5)_"01" 56 .S X=$$FMADD^XLFDT(X,32) 57 .S X=$$FMADD^XLFDT(X,-($E(X,6,7))) 58 .I X>DT S X=DT 59 .S $P(DIR(0),"^",2)=STRTDT_":"_X_":AEXP" 60 .S DIR("A")="Ending with Date: " 61 .S DIR("B")=$$FMTE^XLFDT(X,"5D") 62 .D ^DIR 63 .I $D(DIROUT)!$D(DIRUT)!(Y="") S (STRTDT,ENDDT)="" S OUT=1 Q 64 .S ENDDT=Y 65 .S OUT=1 66 Q:(STRTDT="")!(ENDDT="") 67 S ECXDATES=STRTDT_"^"_ENDDT_"^1" 68 ;Get extract logic to use 69 N ECXLOGIC 70 K DIR 71 S DIR("A")="Select fiscal year logic to use for extract" 72 S DIR(0)="SO^" 73 F X=2003,2004,2005,2006,2007 D 74 .S Y=$E(X,5) 75 .S Y=$S((Y="")!(Y=" "):"",1:"Revision "_Y_" of ") 76 .S DIR(0)=DIR(0)_X_":"_Y_"Fiscal Year "_$E(X,1,4)_";" 77 D ^DIR 78 I $D(DIROUT)!$D(DIRUT) Q 79 S ECXLOGIC=Y 80 ;Queue extract 81 D @("BEG^"_ECXRTN) 82 Q 83 PAUSE ;pause screen 84 N DIR,X,Y,DTOUT,DUOUT,DIROUT,DIRUT 85 S DIR(0)="E" 86 W !! 87 D ^DIR 88 W !! 89 Q -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXTRT.m
r613 r623 1 ECXTRT ;ALB/JAP,BIR/DMA,CML,PTD-Treating Specialty Change Extract ; 10/17/07 3:48pm 2 ;;3.0;DSS EXTRACTS;**1,8,17,24,33,35,39,46,49,84,107,105**;Dec 22, 1997;Build 70 3 BEG ;entry point from option 4 D SETUP I ECFILE="" Q 5 D ^ECXTRAC,^ECXKILL 6 Q 7 ; 8 START ; start package specific extract 9 N LOC,SPC,TRT,WRD 10 S QFLG=0 11 K ECXDD D FIELD^DID(405,.19,,"SPECIFIER","ECXDD") 12 S ECPRO=$E(+$P(ECXDD("SPECIFIER"),"P",2)) K ECXDD 13 K ^TMP($J,"ECXTMP") S TRT=0 14 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 15 S ECED=ECED+.3,ECD=ECSD1 16 ;loop through type 6 movements to get treating specialty and provider changes 17 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 18 .I $D(^DGPM(ECDA,0)) S EC=^(0),ECXDFN=+$P(EC,U,3) D Q:QFLG 19 ..S ECXMVD1=$P(EC,U),WRD=$P(EC,U,6) 20 ..; 21 ..;- Call sets ECXA (In/Out indicator) 22 ..Q:'$$PATDEM^ECXUTL2(ECXDFN,ECXMVD1,"1;",13) 23 ..S ECMT=$P(EC,U,18),ECXADM=$P(EC,U,14),ECXADT=$P($G(^DGPM(ECXADM,0)),U) 24 ..;skip the record if its the admission treat. spec. change for this episode of care 25 ..Q:ECXADM=$P(EC,U,24) 26 ..S (ECXLOS,ECXLOSA,ECXLOSP)="" S ECXDSSD="" 27 ..K LOC D SETLOC(ECXDFN,ECXADM,ECPRO,.LOC) 28 ..;get data for current (new) ts movement 29 ..S ECD1=9999999.9999999-ECXMVD1 30 ..D FINDLOC(ECD1,.LOC,.ECXSPCN,.ECXPRVN,.ECXATTN,.ECXMOVN,.ECXTRTN) 31 ..Q:ECXSPCN="" 32 ..S ECD2=$O(LOC(ECD1)) Q:ECD2="" 33 ..S ECXMVD2=9999999.9999999-ECD2 34 ..;get data for previous (losing) ts movement 35 ..D FINDLOC(ECD2,.LOC,.ECXSPCL,.ECXPRVL,.ECXATTL,.ECXMOVL,.ECXTRTL) 36 ..;if ts has changed, find los on losing ts 37 ..D:ECXTRTL'=ECXTRTN PREVTRT^ECXTRT1(.LOC,ECD1,ECD2,ECXTRTL,.ECXLOS) 38 ..;whether ts has changed or not, see if primary provider has changed 39 ..;don't bother if there's no data on current primary provider or no change in provider 40 ..D:(ECXPRVN'="")&(ECXPRVN'=ECXPRVL) PREVPRV^ECXTRT1(.LOC,ECD1,ECXPRVN,ECD2,.ECXPRVL,.ECXLOSP) 41 ..;whether ts has changed or not, see if attending physician has changed 42 ..;don't bother if there's no data on current attending physician or no change in attending 43 ..D:(ECXATTN'="")&(ECXATTN'=ECXATTL) PREVATT^ECXTRT1(.LOC,ECD1,ECXATTN,ECD2,.ECXATTL,.ECXLOSA) 44 ..S ECXDATE=$$ECXDATE^ECXUTL(ECXMVD1,ECXYM),ECXTIME=$$ECXTIME^ECXUTL(ECXMVD1) 45 ..S ECXADMDT=$$ECXDATE^ECXUTL(ECXADT,ECXYM),ECXADMTM=$$ECXTIME^ECXUTL(ECXADT),ECXDCDT="" 46 ..;- Production Division 47 ..S ECXPDIV="" 48 ..I ECXLOGIC>2003 S ECXPDIV=$S(WRD="":"",1:$$NPDIV(WRD)) 49 ..; 50 ..;- Observation patient indicator (YES/NO) 51 ..S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS) 52 ..; 53 ..;- Chg outpat with movemnt/discharge to inpat (to comply w/existing business rule) 54 ..I ECXA="O"&(ECXOBS="NO")&(ECXMVD1) S ECXA="I" 55 ..; 56 ..;- Get providers person classes 57 .. S ECXATLPC=$$PRVCLASS^ECXUTL($E(ECXATTL,2,999),ECXADT) 58 .. S ECATLNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXATTL,2,999),ECXADT) 59 .. S:+ECATLNPI'>0 ECATLNPI="" S ECATLNPI=$P(ECATLNPI,U) 60 .. S ECXPRNPC=$$PRVCLASS^ECXUTL($E(ECXPRVN,2,999),ECXADT) 61 .. S ECPRVNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXPRVN,2,999),ECXADT) 62 .. S:+ECPRVNPI'>0 ECPRVNPI="" S ECPRVNPI=$P(ECPRVNPI,U) 63 .. S ECXATNPC=$$PRVCLASS^ECXUTL($E(ECXATTN,2,999),ECXADT) 64 .. S ECATTNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXATTN,2,999),ECXADT) 65 .. S:+ECATTNPI'>0 ECATTNPI="" S ECATTNPI=$P(ECATTNPI,U) 66 .. S ECXPRLPC=$$PRVCLASS^ECXUTL($E(ECXPRVL,2,999),ECXADT) 67 .. S ECPRLNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXPRVL,2,999),ECXADT) 68 .. S:+ECPRLNPI'>0 ECPRLNPI="" S ECPRLNPI=$P(ECPRLNPI,U) 69 ..; 70 ..;- If no encounter number, don't file record 71 ..S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADT,,ECXTS,ECXOBS,ECHEAD,,) 72 ..D:ECXENC'="" FILE^ECXTRT2 73 ;for nhcu episodes with intervening asih stays, the los calculated here is not accurate, 74 ;but it never has been; this is best solution within current extract framework; 75 ;at discharge the los calculated for nhcu episodes will be the los since admission w/o asih los subtracted; 76 ; 77 ;loop through discharges to get last treating specialty 78 S ECD=ECSD1 79 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 80 .I $D(^DGPM(ECDA,0)) S EC=^(0),ECXDFN=+$P(EC,U,3) D Q:QFLG 81 ..S ECXMVD1=$P(EC,U),WRD=$P(EC,U,6) 82 ..S (ECXDATE,ECXDCDT)=$$ECXDATE^ECXUTL(ECXMVD1,ECXYM),ECXTIME=$$ECXTIME^ECXUTL(ECXMVD1) 83 ..I ECXDCDT'>0 S ECXDCDT="" 84 ..S ECMT=$P(EC,U,18),ECXADM=$P(EC,U,14),ECXADT=$P($G(^DGPM(ECXADM,0)),U,1) 85 ..S (ECXTRTN,ECXSPCN,ECXPRVN,ECXATTN)="" S (ECXLOS,ECXLOSA,ECXLOSP)="" S ECXDSSD="" 86 ..K LOC D SETLOC(ECXDFN,ECXADM,ECPRO,.LOC) 87 ..S ECD1=9999999.9999999-ECXMVD1 88 ..;get ts change just before d/c 89 ..S ECD2=$O(LOC(ECD1)),ECXMVD2=9999999.9999999-ECD2 90 ..D FINDLOC(ECD2,.LOC,.ECXSPCL,.ECXPRVL,.ECXATTL,.ECXMOVL,.ECXTRTL) 91 ..; 92 ..;- Call sets ECXA (In/Out indicator) using date before discharge 93 ..Q:'$$PATDEM^ECXUTL2(ECXDFN,ECXMVD2,"1;",13) 94 ..S ECXADMDT=$$ECXDATE^ECXUTL(ECXADT,ECXYM),ECXADMTM=$$ECXTIME^ECXUTL(ECXADT) 95 ..;if closest ts change is admission ts, cant go back any further 96 ..S TRT=$O(LOC(ECD2,0)),REC=$O(LOC(ECD2,TRT,0)) 97 ..I REC=ECXADM D 98 ...S X1=ECXMVD1,X2=ECXMVD2 D ^%DTC S ECXLOS=X 99 ...I ECXPRVL'="" S X1=ECXMVD1,X2=ECXMVD2 D ^%DTC S ECXLOSP=X 100 ...I ECXATTL'="" S X1=ECXMVD1,X2=ECXMVD2 D ^%DTC S ECXLOSA=X 101 ..;otherwise, need to find when change to last ts occurred 102 ..I REC'=ECXADM D 103 ...D PREVTRT^ECXTRT1(.LOC,ECD1,ECD2,ECXTRTL,.ECXLOS) 104 ...D PREVPRV^ECXTRT1(.LOC,ECD1,ECXPRVN,ECD2,.ECXPRVL,.ECXLOSP) 105 ...D PREVATT^ECXTRT1(.LOC,ECD1,ECXATTN,ECD2,.ECXATTL,.ECXLOSA) 106 ..S:ECXLOS>9999 ECXLOS=9999 S:ECXLOSA>9999 ECXLOSA=9999 107 ..S:ECXLOSP>9999 ECXLOSP=9999 108 ..;- Production Division 109 ..S ECXPDIV="" 110 ..I ECXLOGIC>2003 S ECXPDIV=$S(WRD="":"",1:$$NPDIV(WRD)) 111 ..; 112 ..;- Observation patient indicator (YES/NO) 113 ..S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS) 114 ..; 115 ..;- Chg outpat with movemnt/discharge to inpat (to comply w/existing business rule) 116 ..I ECXA="O"&(ECXOBS="NO")&(ECXMVD1) S ECXA="I" 117 ..; 118 ..;- Get providers person classes 119 .. S ECXATLPC=$$PRVCLASS^ECXUTL($E(ECXATTL,2,999),ECXADT) 120 .. S ECATLNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXATTL,2,999),ECXADT) 121 .. S:+ECATLNPI'>0 ECATLNPI="" S ECATLNPI=$P(ECATLNPI,U) 122 .. S ECXPRNPC=$$PRVCLASS^ECXUTL($E(ECXPRVN,2,999),ECXADT) 123 .. S ECPRVNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXPRVN,2,999),ECXADT) 124 .. S:+ECPRVNPI'>0 ECPRVNPI="" S ECPRVNPI=$P(ECPRVNPI,U) 125 .. S ECXATNPC=$$PRVCLASS^ECXUTL($E(ECXATTN,2,999),ECXADT) 126 .. S ECATTNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXATTN,2,999),ECXADT) 127 .. S:+ECATTNPI'>0 ECATTNPI="" S ECATTNPI=$P(ECATTNPI,U) 128 .. S ECXPRLPC=$$PRVCLASS^ECXUTL($E(ECXPRVL,2,999),ECXADT) 129 .. S ECPRLNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXPRVL,2,999),ECXADT) 130 .. S:+ECPRLNPI'>0 ECPRLNPI="" S ECPRLNPI=$P(ECPRLNPI,U) 131 ..; 132 ..;- If no encounter number don't file record 133 ..S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADT,,ECXTS,ECXOBS,ECHEAD,,) 134 ..D:ECXENC'="" FILE^ECXTRT2 135 D KPATDEM^ECXUTL2 136 Q 137 ; 138 NPDIV(WRD) ;National Production Division 139 N DIV 140 S DIV=$$GET1^DIQ(42,WRD,.015,"I") 141 Q $S(DIV="":"",1:$$GETDIV^ECXDEPT(DIV)) 142 ; 143 SETLOC(ECXDFN,ECXADM,ECXPRO,ECXLOC) ;setup the local array from the ATS index 144 ; output 145 ; ECXLOC = local array (passed by reference) 146 ; 147 N SUB3,SUB4,SUB5,SPC,PRV,ATT,MOV 148 S SUB3=0 149 F S SUB3=$O(^DGPM("ATS",ECXDFN,ECXADM,SUB3)) Q:SUB3="" D 150 .S (SUB4,SUB5)=0 151 .S SUB4=$O(^DGPM("ATS",ECXDFN,ECXADM,SUB3,SUB4)) 152 .S SUB5=$O(^DGPM("ATS",ECXDFN,ECXADM,SUB3,SUB4,SUB5)) 153 .S ECXLOC(SUB3,SUB4,SUB5)="",SPC=$G(^TMP($J,"ECXTMP",SUB4)) 154 .S DATA=$G(^DGPM(SUB5,0)),PRV=$P(DATA,U,8),ATT=$P(DATA,U,19) 155 .S MOV=$P(DATA,U,14) 156 .S:PRV]"" PRV=ECXPRO_PRV S:ATT]"" ATT=ECXPRO_ATT 157 .S ECXLOC(SUB3,SUB4,SUB5)=SPC_U_PRV_U_ATT_U_MOV 158 Q 159 ; 160 FINDLOC(ECXTSD,ECXLOC,ECXSPC,ECXPRV,ECXATT,ECXMOV,ECXTRT) ;find local array node for current ts movement 161 ; input 162 ; ECXTSD = inverse date/time for current ts movement; required 163 ; ECXLOC = local array; passed by reference; required 164 ; output; data from record contained in MOVE 165 ; ECXSPC = piece 1 of LOC (passed by reference) 166 ; ECXPRV = piece 2 of LOC concatenated to PRO (passed by reference) 167 ; ECXATT = piece 3 of LOC concatenated to PRO (passed by reference) 168 ; ECXMOV = piece 4 of LOC (passed by reference) 169 ; ECXTRT = pointer to file #45.7 170 ; 171 N SUB3,SUB4,SUB5,LOC 172 S (ECXSPC,ECXPRV,ECXATT,ECXMOV)="" 173 S SUB3=ECXTSD 174 I $D(ECXLOC(SUB3)) D 175 .S SUB4=$O(ECXLOC(SUB3,0)),SUB5=$O(ECXLOC(SUB3,SUB4,0)) 176 .S LOC=ECXLOC(SUB3,SUB4,SUB5),ECXTRT=SUB4,ECXSPC=$P(LOC,U) 177 .S ECXPRV=$P(LOC,U,2),ECXATT=$P(LOC,U,3),ECXMOV=$P(LOC,U,4) 178 Q 179 ; 180 SETUP ;Set required input for ECXTRAC 181 S ECHEAD="TRT" 182 D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) 183 Q 184 ; 185 QUE ; entry point for the background requeuing handled by ECXTAUTO 186 D SETUP,QUE^ECXTAUTO,^ECXKILL 187 Q 1 ECXTRT ;ALB/JAP,BIR/DMA,CML,PTD-Treating Specialty Change Extract ; 04/12/2007 2 ;;3.0;DSS EXTRACTS;**1,8,17,24,33,35,39,46,49,84,107**;Dec 22, 1997;Build 9 3 BEG ;entry point from option 4 D SETUP I ECFILE="" Q 5 D ^ECXTRAC,^ECXKILL 6 Q 7 ; 8 START ; start package specific extract 9 N LOC,SPC,TRT,WRD 10 S QFLG=0 11 K ECXDD D FIELD^DID(405,.19,,"SPECIFIER","ECXDD") 12 S ECPRO=$E(+$P(ECXDD("SPECIFIER"),"P",2)) K ECXDD 13 K ^TMP($J,"ECXTMP") S TRT=0 14 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 15 S ECED=ECED+.3,ECD=ECSD1 16 ;loop through type 6 movements to get treating specialty and provider changes 17 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 18 .I $D(^DGPM(ECDA,0)) S EC=^(0),ECXDFN=+$P(EC,U,3) D Q:QFLG 19 ..S ECXMVD1=$P(EC,U),WRD=$P(EC,U,6) 20 ..; 21 ..;- Call sets ECXA (In/Out indicator) 22 ..Q:'$$PATDEM^ECXUTL2(ECXDFN,ECXMVD1,"1;",13) 23 ..S ECMT=$P(EC,U,18),ECXADM=$P(EC,U,14),ECXADT=$P($G(^DGPM(ECXADM,0)),U) 24 ..;skip the record if its the admission treat. spec. change for this episode of care 25 ..Q:ECXADM=$P(EC,U,24) 26 ..S (ECXLOS,ECXLOSA,ECXLOSP)="" S ECXDSSD="" 27 ..K LOC D SETLOC(ECXDFN,ECXADM,ECPRO,.LOC) 28 ..;get data for current (new) ts movement 29 ..S ECD1=9999999.9999999-ECXMVD1 30 ..D FINDLOC(ECD1,.LOC,.ECXSPCN,.ECXPRVN,.ECXATTN,.ECXMOVN,.ECXTRTN) 31 ..Q:ECXSPCN="" 32 ..S ECD2=$O(LOC(ECD1)) Q:ECD2="" 33 ..S ECXMVD2=9999999.9999999-ECD2 34 ..;get data for previous (losing) ts movement 35 ..D FINDLOC(ECD2,.LOC,.ECXSPCL,.ECXPRVL,.ECXATTL,.ECXMOVL,.ECXTRTL) 36 ..;if ts has changed, find los on losing ts 37 ..D:ECXTRTL'=ECXTRTN PREVTRT^ECXTRT1(.LOC,ECD1,ECD2,ECXTRTL,.ECXLOS) 38 ..;whether ts has changed or not, see if primary provider has changed 39 ..;dont bother if there's no data on current primary provider or no change in provider 40 ..D:(ECXPRVN'="")&(ECXPRVN'=ECXPRVL) PREVPRV^ECXTRT1(.LOC,ECD1,ECXPRVN,ECD2,.ECXPRVL,.ECXLOSP) 41 ..;whether ts has changed or not, see if attending physician has changed 42 ..;dont bother if theres no data on current attending physician or no change in attending 43 ..D:(ECXATTN'="")&(ECXATTN'=ECXATTL) PREVATT^ECXTRT1(.LOC,ECD1,ECXATTN,ECD2,.ECXATTL,.ECXLOSA) 44 ..S ECXDATE=$$ECXDATE^ECXUTL(ECXMVD1,ECXYM),ECXTIME=$$ECXTIME^ECXUTL(ECXMVD1) 45 ..S ECXADMDT=$$ECXDATE^ECXUTL(ECXADT,ECXYM),ECXADMTM=$$ECXTIME^ECXUTL(ECXADT),ECXDCDT="" 46 ..;- Production Division 47 ..S ECXPDIV="" 48 ..I ECXLOGIC>2003 S ECXPDIV=$S(WRD="":"",1:$$NPDIV(WRD)) 49 ..S (ECXALNPI,ECXANNPI,ECXPLNPI,ECXPNNPI)="" 50 ..; 51 ..;- Observation patient indicator (YES/NO) 52 ..S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS) 53 ..; 54 ..;- Chg outpat with movemnt/discharge to inpat (to comply w/existing business rule) 55 ..I ECXA="O"&(ECXOBS="NO")&(ECXMVD1) S ECXA="I" 56 ..; 57 ..;- Get providers person classes 58 .. S ECXATLPC=$$PRVCLASS^ECXUTL($E(ECXATTL,2,999),ECXADT) 59 .. S ECXPRNPC=$$PRVCLASS^ECXUTL($E(ECXPRVN,2,999),ECXADT) 60 .. S ECXATNPC=$$PRVCLASS^ECXUTL($E(ECXATTN,2,999),ECXADT) 61 .. S ECXPRLPC=$$PRVCLASS^ECXUTL($E(ECXPRVL,2,999),ECXADT) 62 ..; 63 ..;- If no encounter number, don't file record 64 ..S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADT,,ECXTS,ECXOBS,ECHEAD,,) 65 ..D:ECXENC'="" FILE 66 ;for nhcu episodes with intervening asih stays, the los calculated here is not accurate, 67 ;but it never has been; this is best solution within current extract framework; 68 ;at discharge the los calculated for nhcu apisodes will be the los since admission w/o asih los subtracted; 69 ; 70 ;loop through discharges to get last treating specialty 71 S ECD=ECSD1 72 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 73 .I $D(^DGPM(ECDA,0)) S EC=^(0),ECXDFN=+$P(EC,U,3) D Q:QFLG 74 ..S ECXMVD1=$P(EC,U),WRD=$P(EC,U,6) 75 ..S (ECXDATE,ECXDCDT)=$$ECXDATE^ECXUTL(ECXMVD1,ECXYM),ECXTIME=$$ECXTIME^ECXUTL(ECXMVD1) 76 ..I ECXDCDT'>0 S ECXDCDT="" 77 ..S ECMT=$P(EC,U,18),ECXADM=$P(EC,U,14),ECXADT=$P($G(^DGPM(ECXADM,0)),U,1) 78 ..S (ECXTRTN,ECXSPCN,ECXPRVN,ECXATTN)="" S (ECXLOS,ECXLOSA,ECXLOSP)="" S ECXDSSD="" 79 ..K LOC D SETLOC(ECXDFN,ECXADM,ECPRO,.LOC) 80 ..S ECD1=9999999.9999999-ECXMVD1 81 ..;get ts change just before d/c 82 ..S ECD2=$O(LOC(ECD1)),ECXMVD2=9999999.9999999-ECD2 83 ..D FINDLOC(ECD2,.LOC,.ECXSPCL,.ECXPRVL,.ECXATTL,.ECXMOVL,.ECXTRTL) 84 ..; 85 ..;- Call sets ECXA (In/Out indicator) using date before discharge 86 ..Q:'$$PATDEM^ECXUTL2(ECXDFN,ECXMVD2,"1;",13) 87 ..S ECXADMDT=$$ECXDATE^ECXUTL(ECXADT,ECXYM),ECXADMTM=$$ECXTIME^ECXUTL(ECXADT) 88 ..;if closest ts change is admission ts, cant go back any further 89 ..S TRT=$O(LOC(ECD2,0)),REC=$O(LOC(ECD2,TRT,0)) 90 ..I REC=ECXADM D 91 ...S X1=ECXMVD1,X2=ECXMVD2 D ^%DTC S ECXLOS=X 92 ...I ECXPRVL'="" S X1=ECXMVD1,X2=ECXMVD2 D ^%DTC S ECXLOSP=X 93 ...I ECXATTL'="" S X1=ECXMVD1,X2=ECXMVD2 D ^%DTC S ECXLOSA=X 94 ..;otherwise, need to find when change to last ts occurred 95 ..I REC'=ECXADM D 96 ...D PREVTRT^ECXTRT1(.LOC,ECD1,ECD2,ECXTRTL,.ECXLOS) 97 ...D PREVPRV^ECXTRT1(.LOC,ECD1,ECXPRVN,ECD2,.ECXPRVL,.ECXLOSP) 98 ...D PREVATT^ECXTRT1(.LOC,ECD1,ECXATTN,ECD2,.ECXATTL,.ECXLOSA) 99 ..S:ECXLOS>9999 ECXLOS=9999 S:ECXLOSA>9999 ECXLOSA=9999 100 ..S:ECXLOSP>9999 ECXLOSP=9999 101 ..;- Production Division 102 ..S ECXPDIV="" 103 ..I ECXLOGIC>2003 S ECXPDIV=$S(WRD="":"",1:$$NPDIV(WRD)) 104 ..S (ECXALNPI,ECXANNPI,ECXPLNPI,ECXPNNPI)="" 105 ..; 106 ..;- Observation patient indicator (YES/NO) 107 ..S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS) 108 ..; 109 ..;- Chg outpat with movemnt/discharge to inpat (to comply w/existing business rule) 110 ..I ECXA="O"&(ECXOBS="NO")&(ECXMVD1) S ECXA="I" 111 ..; 112 ..;- Get providers person classes 113 .. S ECXATLPC=$$PRVCLASS^ECXUTL($E(ECXATTL,2,999),ECXADT) 114 .. S ECXPRNPC=$$PRVCLASS^ECXUTL($E(ECXPRVN,2,999),ECXADT) 115 .. S ECXATNPC=$$PRVCLASS^ECXUTL($E(ECXATTN,2,999),ECXADT) 116 .. S ECXPRLPC=$$PRVCLASS^ECXUTL($E(ECXPRVL,2,999),ECXADT) 117 ..; 118 ..;- If no encounter number don't file record 119 ..S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADT,,ECXTS,ECXOBS,ECHEAD,,) 120 ..D:ECXENC'="" FILE 121 D KPATDEM^ECXUTL2 122 Q 123 ; 124 NPDIV(WRD) ;National Production Division 125 N DIV 126 S DIV=$$GET1^DIQ(42,WRD,.015,"I") 127 Q $S(DIV="":"",1:$$GETDIV^ECXDEPT(DIV)) 128 ; 129 SETLOC(ECXDFN,ECXADM,ECXPRO,ECXLOC) ;setup the local array from the ATS index 130 ; output 131 ; ECXLOC = local array (passed by reference) 132 ; 133 N SUB3,SUB4,SUB5,SPC,PRV,ATT,MOV 134 S SUB3=0 135 F S SUB3=$O(^DGPM("ATS",ECXDFN,ECXADM,SUB3)) Q:SUB3="" D 136 .S (SUB4,SUB5)=0 137 .S SUB4=$O(^DGPM("ATS",ECXDFN,ECXADM,SUB3,SUB4)) 138 .S SUB5=$O(^DGPM("ATS",ECXDFN,ECXADM,SUB3,SUB4,SUB5)) 139 .S ECXLOC(SUB3,SUB4,SUB5)="",SPC=$G(^TMP($J,"ECXTMP",SUB4)) 140 .S DATA=$G(^DGPM(SUB5,0)),PRV=$P(DATA,U,8),ATT=$P(DATA,U,19) 141 .S MOV=$P(DATA,U,14) 142 .S:PRV]"" PRV=ECXPRO_PRV S:ATT]"" ATT=ECXPRO_ATT 143 .S ECXLOC(SUB3,SUB4,SUB5)=SPC_U_PRV_U_ATT_U_MOV 144 Q 145 ; 146 FINDLOC(ECXTSD,ECXLOC,ECXSPC,ECXPRV,ECXATT,ECXMOV,ECXTRT) ;find local array node for current ts movement 147 ; input 148 ; ECXTSD = inverse date/time for current ts movement; required 149 ; ECXLOC = local array; passed by reference; required 150 ; output; data from record contained in MOVE 151 ; ECXSPC = piece 1 of LOC (passed by reference) 152 ; ECXPRV = piece 2 of LOC concatenated to PRO (passed by reference) 153 ; ECXATT = piece 3 of LOC concatenated to PRO (passed by reference) 154 ; ECXMOV = piece 4 of LOC (passed by reference) 155 ; ECXTRT = pointer to file #45.7 156 ; 157 N SUB3,SUB4,SUB5,LOC 158 S (ECXSPC,ECXPRV,ECXATT,ECXMOV)="" 159 S SUB3=ECXTSD 160 I $D(ECXLOC(SUB3)) D 161 .S SUB4=$O(ECXLOC(SUB3,0)),SUB5=$O(ECXLOC(SUB3,SUB4,0)) 162 .S LOC=ECXLOC(SUB3,SUB4,SUB5),ECXTRT=SUB4,ECXSPC=$P(LOC,U) 163 .S ECXPRV=$P(LOC,U,2),ECXATT=$P(LOC,U,3),ECXMOV=$P(LOC,U,4) 164 Q 165 ; 166 FILE ;file the extract record 167 ;node0 168 ;^dfn^ssn^name^i/o (ECXA)^date^product^adm date^d/c date^ 169 ;mov#^type^new ts^losing ts^losing ts los^ 170 ;losing attending^movement type^time^adm time^new provider^ 171 ;new attending^losing provider 172 ;node1 173 ;mpi^dss dept^losing attending npi^new provider npi^new attending npi^ 174 ;losing provider npi^losing attending los^losing provider los^dom^ 175 ;observ pat ind^encounter num 176 ; 177 ;convert specialties to PTF Codes for transmission 178 ; 179 N ECXDATA 180 S ECXDATA=$$TSDATA^DGACT(42.4,+ECXSPCN,.ECXDATA) 181 S ECXSPCN=$G(ECXDATA(7)) 182 S ECXDATA=$$TSDATA^DGACT(42.4,+ECXSPCL,.ECXDATA) 183 S ECXSPCL=$G(ECXDATA(7)) 184 ;done 185 S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 186 S ECODE=EC7_U_EC23_U_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U_ECXDATE_U_U 187 S ECODE=ECODE_ECXADMDT_U_ECXDCDT_U_ECDA_U_6_U_ECXSPCN_U_ECXSPCL_U 188 S ECODE=ECODE_ECXLOS_U_ECXATTL_U_ECMT_U_ECXTIME_U_ECXADMTM_U_ECXPRVN_U 189 S ECODE=ECODE_ECXATTN_U_ECXPRVL_U 190 S ECODE1=ECXMPI_U_ECXDSSD_U_ECXALNPI_U_ECXPNNPI_U_ECXANNPI_U_ECXPLNPI_U 191 S ECODE1=ECODE1_ECXLOSA_U_ECXLOSP_U_ECXDOM_U_ECXOBS_U_ECXENC_U_ECXPDIV 192 I ECXLOGIC>2005 S ECODE1=ECODE1_U_ECXATLPC_U_ECXPRNPC_U_ECXATNPC_U_ECXPRLPC 193 S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,ECRN=ECRN+1 194 S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA 195 I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 196 Q 197 ; 198 SETUP ;Set required input for ECXTRAC 199 S ECHEAD="TRT" 200 D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) 201 Q 202 ; 203 QUE ; entry point for the background requeuing handled by ECXTAUTO 204 D SETUP,QUE^ECXTAUTO,^ECXKILL 205 Q -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXUD.m
r613 r623 1 ECXUD ;ALB/JAP,BIR/DMA,PTD-Extract from UNIT DOSE EXTRACT DATA File (#728.904) ; 10/31/07 1:58pm 2 ;;3.0;DSS EXTRACTS;**10,8,24,33,39,46,49,71,84,92,107,105**;Dec 22, 1997;Build 70 3 BEG ;entry point from option 4 I '$O(^ECX(728.904,"A",0)) W !,"There are no unit dose orders to extract",!! R X:5 K X Q 5 D SETUP I ECFILE="" Q 6 D ^ECXTRAC,^ECXKILL 7 Q 8 ; 9 START ;start package specific extract 10 S QFLG=0 11 S ECED=ECED+.3 12 F ECD=ECSD1:0 S ECD=$O(^ECX(728.904,"A",ECD)) Q:'ECD Q:ECD>ECED Q:QFLG D 13 .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 14 ..S DATA=^ECX(728.904,ECXJ,0),^(1)=$P(EC23,U,2),^ECX(728.904,"AC",$P(EC23,U,2),ECXJ)="" D STUFF 15 K ^TMP($J,"ECXP") 16 Q 17 ; 18 STUFF ;get data 19 N X,W,OK,P1,P3,PSTAT,PT,ECXPHA,ON,ECDRG 20 S ECXDFN=$P(DATA,U,2),ECDRG=$P(DATA,U,4) 21 ; 22 ;get patient specific data 23 S ECXERR="" D PAT(ECXDFN,ECD,.ECXERR) 24 Q:ECXERR 25 ; 26 S ECXPRO=$P(DATA,U,7),ECPROIEN=+ECXPRO,ECXPRO=$E($P(ECXPRO,";",2))_$P(ECXPRO,";") 27 S ECXPRNPI=$$NPI^XUSNPI("Individual_ID",ECPROIEN,ECD) 28 S:+ECXPRNPI'>0 ECXPRNPI="" S ECXPRNPI=$P(ECXPRNPI,U) 29 S W=$P(DATA,U,6) 30 S ECXDIV=$P($G(^DIC(42,+W,0)),U,11),ECXW=$P($G(^DIC(42,+W,44)),U) 31 S ECXUDDT=$$ECXDATE^ECXUTL($P(DATA,U,3),ECXYM) 32 S ECXUDTM=$E($P($P(DATA,U,3),".",2)_"000000",1,6) 33 S ECXQTY=$P(DATA,U,5),ECXCOST=$P(DATA,U,8),ON=$P(DATA,U,10) 34 ;call pharmacy drug file (#50) api via ecxutl5 35 S ECXPHA=$$PHAAPI^ECXUTL5(ECDRG) 36 S ECCAT=$P(ECXPHA,U,2),ECINV=$P(ECXPHA,U,4) 37 S ECINV=$S(ECINV["I":"I",1:"") 38 S ECNDC=$P(ECXPHA,U,3) 39 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) 40 S P1=$P(ECXPHA,U,5),P3=$P(ECXPHA,U,6),X="PSNAPIS" 41 X ^%ZOSF("TEST") I $T S ECNFC=$$DSS^PSNAPIS(P1,P3,ECXYM)_ECNFC 42 I $L(ECNFC)=12 S ECNFC=$$RJ^XLFSTR(P1,4,0)_$$RJ^XLFSTR(P3,3,0)_ECNFC 43 ; - Department and National Production Division 44 ;- Use of DSS Department postponed [S ECXDSSD=$$UDP^ECXDEPT(ECXDIV)] 45 S ECXDSSD="" 46 S ECXPDIV=$$GETDIV^ECXDEPT(ECXDIV) 47 ;- Observation patient indicator (YES/NO) 48 S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS) 49 ;- Ordering Date, Ordering Stop Code 50 S ECXORDDT=$TR($$FMTE^XLFDT($P(DATA,U,9),"7DF")," /","0") 51 S ECXORDST="" I ECXA="O" D 52 .;Get ordering stop code based on FY 2006 logic for outpatient 53 .S ECXORDST=$$DOUDO^ECXUTL5(ECXDFN,ON) 54 ;Ordering Provider Person Class 55 S ECXOPPC=$$PRVCLASS^ECXUTL($E(ECXPRO,2,999),$P(DATA,U,9)) 56 ;BCMA data (place holder) 57 S (ECXBCDD,ECXBCDG,ECXBCUA,ECXBCIF)="" 58 ;- Set national patient record flag if exist 59 D NPRF^ECXUTL5 60 ;- If no encounter number don't file record 61 S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADM,$P(DATA,U,3),ECXTS,ECXOBS,ECHEAD,,) 62 D:ECXENC'="" FILE 63 Q 64 ; 65 PAT(ECXDFN,ECXDATE,ECXERR) ;get demographics from patient file 66 ;init variables 67 S (ECXCAT,ECXSTAT,ECXPRIOR,ECXSBGRP,ECXOEF,ECXOEFDT)="" 68 ;get patient data if saved 69 I $D(^TMP($J,"ECXP",ECXDFN)) D 70 .S PT=^TMP($J,"ECXP",ECXDFN),ECXPNM=$P(PT,U),ECXSSN=$P(PT,U,2) 71 .S ECXMPI=$P(PT,U,3),ECXDOB=$P(PT,U,4) 72 .S ECXELIG=$P(PT,U,5),ECXSEX=$P(PT,U,6) 73 .S ECXSTATE=$P(PT,U,7),ECXCNTY=$P(PT,U,8),ECXZIP=$P(PT,U,9) 74 .S ECXVET=$P(PT,U,10),ECXPOS=$P(PT,U,11),ECXPST=$P(PT,U,12) 75 .S ECXPLOC=$P(PT,U,13),ECXRST=$P(PT,U,14),ECXAST=$P(PT,U,15) 76 .S ECXAOL=$P(PT,U,16),ECXPHI=$P(PT,U,17),ECXMST=$P(PT,U,18) 77 .S ECXENRL=$P(PT,U,19),ECXCNHU=$P(PT,U,20),ECXCAT=$P(PT,U,21) 78 .S ECXSTAT=$P(PT,U,22),ECXPRIOR=$P(PT,U,23),ECXHNCI=$P(PT,U,24) 79 .S ECXETH=$P(PT,U,25),ECXRC1=$P(PT,U,26),ECXMTST=$P(PT,U,27) 80 .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) 81 .I $$ENROLLM^ECXUTL2(ECXDFN) 82 ;set patient data 83 I '$D(^TMP($J,"ECXP",ECXDFN)) D Q:'OK 84 .K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECXDATE,"."),"1;2;3;5",.ECXPAT) 85 .I 'OK K ECXPAT S ECXERR=1 Q 86 .S ECXPNM=ECXPAT("NAME"),ECXSSN=ECXPAT("SSN"),ECXMPI=ECXPAT("MPI") 87 .S ECXDOB=ECXPAT("DOB"),ECXELIG=ECXPAT("ELIG"),ECXSEX=ECXPAT("SEX") 88 .S ECXSTATE=ECXPAT("STATE"),ECXCNTY=ECXPAT("COUNTY") 89 .S ECXZIP=ECXPAT("ZIP"),ECXVET=ECXPAT("VET") 90 .S ECXPOS=ECXPAT("POS"),ECXPST=ECXPAT("POW STAT") 91 .S ECXPLOC=ECXPAT("POW LOC"),ECXRST=ECXPAT("IR STAT") 92 .S ECXAST=ECXPAT("AO STAT"),ECXAOL=ECXPAT("AOL") 93 .S ECXPHI=ECXPAT("PHI"),ECXMST=ECXPAT("MST STAT") 94 .S ECXENRL=ECXPAT("ENROLL LOC"),ECXMTST=ECXPAT("MEANS") 95 .;OEF/OIF data 96 .S ECXOEF=ECXPAT("ECXOEF") 97 .S ECXOEFDT=ECXPAT("ECXOEFDT") 98 .;get CNHU status 99 .S ECXCNHU=$$CNHSTAT^ECXUTL4(ECXDFN) 100 .;get enrollment data (category, status and priority) 101 .I $$ENROLLM^ECXUTL2(ECXDFN) 102 .; - Head and Neck Cancer Indicator 103 .S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) 104 .; - Race and Ethnicity 105 .S ECXETH=ECXPAT("ETHNIC") 106 .S ECXRC1=ECXPAT("RACE1") 107 .;get emergency response indicator (FEMA) 108 .S ECXERI=ECXPAT("ERI") 109 .S ECXEST=ECXPAT("EC STAT") 110 .;save for later 111 .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 112 .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 113 .S ^TMP($J,"ECXP",ECXDFN,1)=ECXERI_U_ECXEST_U_ECXOEF_U_ECXOEFDT 114 ; 115 ;get inpatient data 116 S X=$$INP^ECXUTL2(ECXDFN,ECXDATE),ECXA=$P(X,U),ECXMN=$P(X,U,2) 117 S ECXTS=$P(X,U,3),ECXADM=$P(X,U,4),ECXDOM=$P(X,U,10) 118 ; 119 ;get primary care data 120 S X=$$PRIMARY^ECXUTL2(ECXDFN,$P(ECXDATE,".")) 121 S ECPTTM=$P(X,U),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4) 122 S ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7) 123 Q 124 ; 125 FILE ;file record 126 ;node0 127 ;facility^dfn^ssn^name^in/out^day^drug category^quantity^ward^ 128 ;provider^cost^mov #^treat spec^ndc^new feeder key^investigational^ 129 ;udp time^adm date^adm time 130 ;node1 131 ;mpi^dss dept^provider npi^dom^observ pat ind^encounter num^ 132 ;prod div code^means tst^elig^dob^sex^state^county^zip+4^vet^ 133 ;period of svc^pow stat^pow loc^ir status^ao status^ao loc^ 134 ;purple heart ind.^mst status^cnh/sh status^enrollment loc^ 135 ;enrollment cat^enrollment status^enrollment priority^pc team^ 136 ;pc provider^pc provider npi^pc provider p.class^assoc. pc provider^ 137 ;assoc. pc provider npi^assoc. pc provider p.class 138 ;node2 139 ;ordering date^ordering stop code^head & neck cancer ind.^ethnicity^ 140 ;race1^bcma drug dispensed^bcma dose given^bcma unit of 141 ;administration^bcma icu flag^ordering provider person class^ 142 ;^enrollment priority ECXPRIOR_enrollment subgroup 143 ;ECXSBGRP^user enrollee ECXUESTA^patient type ECXPTYPE^combat vet 144 ;elig ECXCVE^combat vet elig end date ECXCVEDT^enc cv eligible 145 ;ECXCVENC^national patient record flag ECXNPRFI^emerg resp indic(FEMA) 146 ;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 147 N DA,DIK 148 S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 149 S ECODE=EC7_U_EC23_U_ECXDIV_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U 150 S ECODE=ECODE_ECXUDDT_U_ECCAT_U_ECXQTY_U_ECXW_U_ECXPRO_U_ECXCOST_U 151 S ECODE=ECODE_ECXMN_U_ECXTS_U_ECNDC_U_ECNFC_U_ECINV_U_ECXUDTM_U 152 ;convert specialty to PTF Code for transmission 153 N ECXDATA 154 S ECXDATA=$$TSDATA^DGACT(42.4,+ECXTS,.ECXDATA) 155 S ECXTS=$G(ECXDATA(7)) 156 ;done 157 S ECODE=ECODE_$$ECXDATE^ECXUTL(ECXADM,ECXYM)_U 158 S ECODE=ECODE_$$ECXTIME^ECXUTL(ECXADM)_U 159 S ECODE1=ECXMPI_U_ECXDSSD_U_U_ECXDOM_U_ECXOBS_U_ECXENC_U 160 S ECODE1=ECODE1_ECXPDIV_U_ECXMTST_U_ECXELIG_U_ECXDOB_U_ECXSEX_U 161 S ECODE1=ECODE1_ECXSTATE_U_ECXCNTY_U_ECXZIP_U_ECXVET_U_ECXPOS_U 162 S ECODE1=ECODE1_ECXPST_U_ECXPLOC_U_ECXRST_U_ECXAST_U 163 S ECODE1=ECODE1_ECXAOL_U_ECXPHI_U_ECXMST_U_ECXCNHU_U_ECXENRL_U 164 S ECODE1=ECODE1_ECXCAT_U_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECPTTM_U_ECPTPR_U 165 S ECODE1=ECODE1_U_ECCLAS_U_ECASPR_U_U_ECCLAS2_U 166 S ECODE2=ECXORDDT_U_ECXORDST_U_ECXHNCI_U_ECXETH_U_ECXRC1 167 I ECXLOGIC>2003 S ECODE2=ECODE2_U_ECXBCDD_U_ECXBCDG_U_ECXBCUA_U_ECXBCIF_U_ECXOPPC 168 I ECXLOGIC>2004 S ECODE2=ECODE2_U_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXNPRFI 169 I ECXLOGIC>2006 S ECODE2=ECODE2_U_ECXERI_U_ECXEST 170 I ECXLOGIC>2007 S ECODE2=ECODE2_U_ECXOEF_U_ECXOEFDT_U_ECASNPI_U_ECPTNPI_U_ECXPRNPI 171 S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1 172 S ^ECX(ECFILE,EC7,2)=ECODE2,ECRN=ECRN+1 173 S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA 174 I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 175 Q 176 ; 177 SETUP ;Set required input for ECXTRAC 178 S ECHEAD="UDP" 179 D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) 180 Q 181 ; 182 QUE ; entry point for the background requeuing handled by ECXTAUTO 183 D SETUP,QUE^ECXTAUTO,^ECXKILL 184 Q 1 ECXUD ;ALB/JAP,BIR/DMA,PTD-Extract from UNIT DOSE EXTRACT DATA File (#728.904) ;4/19/2007 2 ;;3.0;DSS EXTRACTS;**10,8,24,33,39,46,49,71,84,92,107**;Dec 22, 1997;Build 9 3 BEG ;entry point from option 4 I '$O(^ECX(728.904,"A",0)) W !,"There are no unit dose orders to extract",!! R X:5 K X Q 5 D SETUP I ECFILE="" Q 6 D ^ECXTRAC,^ECXKILL 7 Q 8 ; 9 START ;start package specific extract 10 S QFLG=0 11 S ECED=ECED+.3 12 F ECD=ECSD1:0 S ECD=$O(^ECX(728.904,"A",ECD)) Q:'ECD Q:ECD>ECED Q:QFLG D 13 .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 14 ..S DATA=^ECX(728.904,ECXJ,0),^(1)=$P(EC23,U,2),^ECX(728.904,"AC",$P(EC23,U,2),ECXJ)="" D STUFF 15 K ^TMP($J,"ECXP") 16 Q 17 ; 18 STUFF ;get data 19 N X,W,OK,P1,P3,PSTAT,PT,ECXPHA,ON,ECDRG 20 S ECXDFN=$P(DATA,U,2),ECDRG=$P(DATA,U,4) 21 ; 22 ;get patient specific data 23 S ECXERR="" D PAT(ECXDFN,ECD,.ECXERR) 24 Q:ECXERR 25 ; 26 S ECXPRO=$P(DATA,U,7),ECXPRO=$E($P(ECXPRO,";",2))_$P(ECXPRO,";") 27 S ECXPRNPI="",W=$P(DATA,U,6) 28 S ECXDIV=$P($G(^DIC(42,+W,0)),U,11),ECXW=$P($G(^DIC(42,+W,44)),U) 29 S ECXUDDT=$$ECXDATE^ECXUTL($P(DATA,U,3),ECXYM) 30 S ECXUDTM=$E($P($P(DATA,U,3),".",2)_"000000",1,6) 31 S ECXQTY=$P(DATA,U,5),ECXCOST=$P(DATA,U,8),ON=$P(DATA,U,10) 32 ;call pharmacy drug file (#50) api via ecxutl5 33 S ECXPHA=$$PHAAPI^ECXUTL5(ECDRG) 34 S ECCAT=$P(ECXPHA,U,2),ECINV=$P(ECXPHA,U,4) 35 S ECINV=$S(ECINV["I":"I",1:"") 36 S ECNDC=$P(ECXPHA,U,3) 37 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) 38 S P1=$P(ECXPHA,U,5),P3=$P(ECXPHA,U,6),X="PSNAPIS" 39 X ^%ZOSF("TEST") I $T S ECNFC=$$DSS^PSNAPIS(P1,P3,ECXYM)_ECNFC 40 I $L(ECNFC)=12 S ECNFC=$$RJ^XLFSTR(P1,4,0)_$$RJ^XLFSTR(P3,3,0)_ECNFC 41 ; - Department and National Production Division 42 ;- Use of DSS Department postponed [S ECXDSSD=$$UDP^ECXDEPT(ECXDIV)] 43 S ECXDSSD="" 44 S ECXPDIV=$$GETDIV^ECXDEPT(ECXDIV) 45 ;- Observation patient indicator (YES/NO) 46 S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS) 47 ;- Ordering Date, Ordering Stop Code 48 S ECXORDDT=$TR($$FMTE^XLFDT($P(DATA,U,9),"7DF")," /","0") 49 S ECXORDST="" I ECXA="O" D 50 .;Get ordering stop code based on FY 2006 logic for outpatient 51 .S ECXORDST=$$DOUDO^ECXUTL5(ECXDFN,ON) 52 ;Ordering Provider Person Class 53 S ECXOPPC=$$PRVCLASS^ECXUTL($E(ECXPRO,2,999),$P(DATA,U,9)) 54 ;BCMA data (place holder) 55 S (ECXBCDD,ECXBCDG,ECXBCUA,ECXBCIF)="" 56 ;- Set national patient record flag if exist 57 D NPRF^ECXUTL5 58 ;- If no encounter number don't file record 59 S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADM,$P(DATA,U,3),ECXTS,ECXOBS,ECHEAD,,) 60 D:ECXENC'="" FILE 61 Q 62 ; 63 PAT(ECXDFN,ECXDATE,ECXERR) ;get demographics from patient file 64 ;init variables 65 S (ECXCAT,ECXSTAT,ECXPRIOR,ECXSBGRP)="" 66 ;get patient data if saved 67 I $D(^TMP($J,"ECXP",ECXDFN)) D 68 .S PT=^TMP($J,"ECXP",ECXDFN),ECXPNM=$P(PT,U),ECXSSN=$P(PT,U,2) 69 .S ECXMPI=$P(PT,U,3),ECXDOB=$P(PT,U,4) 70 .S ECXELIG=$P(PT,U,5),ECXSEX=$P(PT,U,6) 71 .S ECXSTATE=$P(PT,U,7),ECXCNTY=$P(PT,U,8),ECXZIP=$P(PT,U,9) 72 .S ECXVET=$P(PT,U,10),ECXPOS=$P(PT,U,11),ECXPST=$P(PT,U,12) 73 .S ECXPLOC=$P(PT,U,13),ECXRST=$P(PT,U,14),ECXAST=$P(PT,U,15) 74 .S ECXAOL=$P(PT,U,16),ECXPHI=$P(PT,U,17),ECXMST=$P(PT,U,18) 75 .S ECXENRL=$P(PT,U,19),ECXCNHU=$P(PT,U,20),ECXCAT=$P(PT,U,21) 76 .S ECXSTAT=$P(PT,U,22),ECXPRIOR=$P(PT,U,23),ECXHNCI=$P(PT,U,24) 77 .S ECXETH=$P(PT,U,25),ECXRC1=$P(PT,U,26),ECXMTST=$P(PT,U,27) 78 .S PT1=$G(^TMP($J,"ECXP",ECXDFN,1)),ECXERI=$P(PT1,U),ECXEST=$P(PT1,U,2) 79 .I $$ENROLLM^ECXUTL2(ECXDFN) 80 ;set patient data 81 I '$D(^TMP($J,"ECXP",ECXDFN)) D Q:'OK 82 .K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECXDATE,"."),"1;2;3;5",.ECXPAT) 83 .I 'OK K ECXPAT S ECXERR=1 Q 84 .S ECXPNM=ECXPAT("NAME"),ECXSSN=ECXPAT("SSN"),ECXMPI=ECXPAT("MPI") 85 .S ECXDOB=ECXPAT("DOB"),ECXELIG=ECXPAT("ELIG"),ECXSEX=ECXPAT("SEX") 86 .S ECXSTATE=ECXPAT("STATE"),ECXCNTY=ECXPAT("COUNTY") 87 .S ECXZIP=ECXPAT("ZIP"),ECXVET=ECXPAT("VET") 88 .S ECXPOS=ECXPAT("POS"),ECXPST=ECXPAT("POW STAT") 89 .S ECXPLOC=ECXPAT("POW LOC"),ECXRST=ECXPAT("IR STAT") 90 .S ECXAST=ECXPAT("AO STAT"),ECXAOL=ECXPAT("AOL") 91 .S ECXPHI=ECXPAT("PHI"),ECXMST=ECXPAT("MST STAT") 92 .S ECXENRL=ECXPAT("ENROLL LOC"),ECXMTST=ECXPAT("MEANS") 93 .;get CNHU status 94 .S ECXCNHU=$$CNHSTAT^ECXUTL4(ECXDFN) 95 .;get enrollment data (category, status and priority) 96 .I $$ENROLLM^ECXUTL2(ECXDFN) 97 .; - Head and Neck Cancer Indicator 98 .S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) 99 .; - Race and Ethnicity 100 .S ECXETH=ECXPAT("ETHNIC") 101 .S ECXRC1=ECXPAT("RACE1") 102 .;get emergency response indicator (FEMA) 103 .S ECXERI=ECXPAT("ERI") 104 .S ECXEST=ECXPAT("EC STAT") 105 .;save for later 106 .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 107 .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 108 .S ^TMP($J,"ECXP",ECXDFN,1)=ECXERI_U_ECXEST 109 ; 110 ;get inpatient data 111 S X=$$INP^ECXUTL2(ECXDFN,ECXDATE),ECXA=$P(X,U),ECXMN=$P(X,U,2) 112 S ECXTS=$P(X,U,3),ECXADM=$P(X,U,4),ECXDOM=$P(X,U,10) 113 ; 114 ;get primary care data 115 S X=$$PRIMARY^ECXUTL2(ECXDFN,$P(ECXDATE,".")) 116 S ECPTTM=$P(X,U),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4) 117 S ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7) 118 Q 119 ; 120 FILE ;file record 121 ;node0 122 ;facility^dfn^ssn^name^in/out^day^drug category^quantity^ward^ 123 ;provider^cost^mov #^treat spec^ndc^new feeder key^investigational^ 124 ;udp time^adm date^adm time 125 ;node1 126 ;mpi^dss dept^provider npi^dom^observ pat ind^encounter num^ 127 ;prod div code^means tst^elig^dob^sex^state^county^zip+4^vet^ 128 ;period of svc^pow stat^pow loc^ir status^ao status^ao loc^ 129 ;purple heart ind.^mst status^cnh/sh status^enrollment loc^ 130 ;enrollment cat^enrollment status^enrollment priority^pc team^ 131 ;pc provider^pc provider npi^pc provider p.class^assoc. pc provider^ 132 ;assoc. pc provider npi^assoc. pc provider p.class 133 ;node2 134 ;ordering date^ordering stop code^head & neck cancer ind.^ethnicity^ 135 ;race1^bcma drug dispensed^bcma dose given^bcma unit of 136 ;administration^bcma icu flag^ordering provider person class^ 137 ;^enrollment priority ECXPRIOR_enrollment subgroup 138 ;ECXSBGRP^user enrollee ECXUESTA^patient type ECXPTYPE^combat vet 139 ;elig ECXCVE^combat vet elig end date ECXCVEDT^enc cv eligible 140 ;ECXCVENC^national patient record flag ECXNPRFI^emerg resp indic(FEMA) 141 ;ECXERI^environ contamin ECXEST 142 N DA,DIK 143 S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1 144 S ECODE=EC7_U_EC23_U_ECXDIV_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U 145 S ECODE=ECODE_ECXUDDT_U_ECCAT_U_ECXQTY_U_ECXW_U_ECXPRO_U_ECXCOST_U 146 S ECODE=ECODE_ECXMN_U_ECXTS_U_ECNDC_U_ECNFC_U_ECINV_U_ECXUDTM_U 147 ;convert specialty to PTF Code for transmission 148 N ECXDATA 149 S ECXDATA=$$TSDATA^DGACT(42.4,+ECXTS,.ECXDATA) 150 S ECXTS=$G(ECXDATA(7)) 151 ;done 152 S ECODE=ECODE_$$ECXDATE^ECXUTL(ECXADM,ECXYM)_U 153 S ECODE=ECODE_$$ECXTIME^ECXUTL(ECXADM)_U 154 S ECODE1=ECXMPI_U_ECXDSSD_U_ECXPRNPI_U_ECXDOM_U_ECXOBS_U_ECXENC_U 155 S ECODE1=ECODE1_ECXPDIV_U_ECXMTST_U_ECXELIG_U_ECXDOB_U_ECXSEX_U 156 S ECODE1=ECODE1_ECXSTATE_U_ECXCNTY_U_ECXZIP_U_ECXVET_U_ECXPOS_U 157 S ECODE1=ECODE1_ECXPST_U_ECXPLOC_U_ECXRST_U_ECXAST_U 158 S ECODE1=ECODE1_ECXAOL_U_ECXPHI_U_ECXMST_U_ECXCNHU_U_ECXENRL_U 159 S ECODE1=ECODE1_ECXCAT_U_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECPTTM_U_ECPTPR_U 160 S ECODE1=ECODE1_ECPTNPI_U_ECCLAS_U_ECASPR_U_ECASNPI_U_ECCLAS2_U 161 S ECODE2=ECXORDDT_U_ECXORDST_U_ECXHNCI_U_ECXETH_U_ECXRC1 162 I ECXLOGIC>2003 S ECODE2=ECODE2_U_ECXBCDD_U_ECXBCDG_U_ECXBCUA_U_ECXBCIF_U_ECXOPPC 163 I ECXLOGIC>2004 S ECODE2=ECODE2_U_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXNPRFI 164 I ECXLOGIC>2006 S ECODE2=ECODE2_U_ECXERI_U_ECXEST 165 S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1 166 S ^ECX(ECFILE,EC7,2)=ECODE2,ECRN=ECRN+1 167 S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA 168 I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 169 Q 170 ; 171 SETUP ;Set required input for ECXTRAC 172 S ECHEAD="UDP" 173 D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER) 174 Q 175 ; 176 QUE ; entry point for the background requeuing handled by ECXTAUTO 177 D SETUP,QUE^ECXTAUTO,^ECXKILL 178 Q -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXUPRO.m
r613 r623 1 ECXUPRO ;ALB/TJL-Prosthetic Extract Unusual Cost Report ; 1/08/08 1:00pm 2 ;;3.0;DSS EXTRACTS;**49,111**;July 1, 2003;Build 4 3 ; 4 EN ; entry point 5 N X,Y,DATE,ECRUN,ECXDESC,ECXSAVE,ECXTL,ECTHLD 6 N ECINST,ECSD,ECSD1,ECSTART,ECED,ECEND,ECXERR,QFLG 7 S QFLG=0 8 S ECINST=$$PDIV^ECXPUTL 9 ; get today's date 10 D NOW^%DTC S DATE=X,Y=$E(%,1,12) D DD^%DT S ECRUN=$P(Y,"@") K %DT 11 D BEGIN Q:QFLG 12 D SELECT Q:QFLG 13 S ECXDESC="Prosthetic Extract Unusual Cost Report" 14 S ECXSAVE("EC*")="" 15 W !!,"This report requires 132-column format." 16 D EN^XUTMDEVQ("PROCESS^ECXUPRO",ECXDESC,.ECXSAVE) 17 I POP W !!,"No device selected...exiting.",! Q 18 I IO'=IO(0) D ^%ZISC 19 D HOME^%ZIS 20 D AUDIT^ECXKILL 21 Q 22 ; 23 BEGIN ; display report description 24 W @IOF 25 W !,"This report prints a listing of unusual costs that would be" 26 W !,"generated by the Prosthetic extract (PRO) as determined by a" 27 W !,"user-defined threshold value. It should be run prior to the" 28 W !,"generation of the actual extract(s) to identify and fix, as" 29 W !,"necessary, any costs determined to be erroneous." 30 W !!,"Unusual costs are those where the Cost of Transaction is" 31 W !,"greater than the threshold value." 32 W !!,"Note: The threshold can be set after a report is selected." 33 W !!,"Run times for this report will vary depending upon the size of" 34 W !,"the extract and could take as long as 30 minutes or more to" 35 W !,"complete. This report has no effect on the actual extracts and" 36 W !,"can be run as needed." 37 W !!,"The report is sorted by Feeder Key, then by descending Cost of" 38 W !,"Transaction and SSN." 39 S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q 40 W:$Y!($E(IOST)="C") @IOF,!! 41 Q 42 ; 43 SELECT ; user inputs for threshold cost and date range 44 N DONE,OUT 45 ; allow user to set threshold cost 46 S ECTHLD=500 47 W !!,"The default threshold cost for the Prosthetic extract is $"_ECTHLD_".00." 48 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 49 I Y D 50 .W !!,"Cost > threshold" 51 .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 52 ; get date range from user 53 W !!,"Enter the date range for which you would like to scan the Prosthetic",!,"Extract records.",! 54 S DONE=0 F S (ECED,ECSD)="" D Q:QFLG!DONE 55 .K %DT S %DT="AEX",%DT("A")="Starting with Date: ",%DT(0)=-DATE D ^%DT 56 .I Y<0 S QFLG=1 Q 57 .S ECSD=Y,ECSD1=ECSD-.1 58 .D DD^%DT S ECSTART=Y 59 .K %DT S %DT="AEX",%DT("A")="Ending with Date: ",%DT(0)=-DATE D ^%DT 60 .I Y<0 S QFLG=1 Q 61 .I Y<ECSD D Q 62 ..W !!,"The ending date cannot be earlier than the starting date." 63 ..W !,"Please try again.",!! 64 .I $E(Y,1,5)'=$E(ECSD,1,5) D Q 65 ..W !!,"Beginning and ending dates must be in the same month and year." 66 ..W !,"Please try again.",!! 67 .S ECED=Y 68 .D DD^%DT S ECEND=Y 69 .S DONE=1 70 Q 71 ; 72 PROCESS ; entry point for queued report 73 S ZTREQ="@" 74 S ECXERR=0 D EN^ECXUPRO1 Q:ECXERR 75 S QFLG=0 D PRINT 76 Q 77 ; 78 PRINT ; process temp file and print report 79 N PG,QFLG,GTOT,LN,COUNT,FKEY,COST,SSN,REC,SDAY 80 U IO 81 I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ Q 82 S (PG,QFLG,GTOT)=0,$P(LN,"-",132)="" 83 D HEADER Q:QFLG 84 S COUNT=0,FKEY="" 85 F S FKEY=$O(^TMP($J,FKEY)) Q:FKEY=""!QFLG D 86 .S COST="" F S COST=$O(^TMP($J,FKEY,COST)) Q:COST=""!QFLG D 87 .. S SDAY="" F S SDAY=$O(^TMP($J,FKEY,COST,SDAY)) Q:SDAY=""!QFLG D 88 ...S SSN="" F S SSN=$O(^TMP($J,FKEY,COST,SDAY,SSN)) Q:SSN=""!QFLG S REC=^(SSN) D 89 ....S COUNT=COUNT+1 90 ....I $Y+3>IOSL D HEADER Q:QFLG 91 ....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) 92 Q:QFLG 93 I COUNT=0 W !!,?8,"No unusual costs to report for this extract" 94 CLOSE ; 95 I $E(IOST)="C",'QFLG D 96 .S SS=22-$Y F JJ=1:1:SS W ! 97 .S DIR(0)="E" W ! D ^DIR K DIR 98 Q 99 ; 100 HEADER ;header and page control 101 N SS,JJ 102 I $E(IOST)="C" D 103 .S SS=22-$Y F JJ=1:1:SS W ! 104 .I PG>0 S DIR(0)="E" W ! D ^DIR K DIR S:'Y QFLG=1 105 Q:QFLG 106 W:$Y!($E(IOST)="C") @IOF S PG=PG+1 107 W !,"Prosthetic Extract Unusual Cost Report",?124,"Page: "_PG 108 W !,"Start Date: ",ECSTART,?97,"Report Run Date/Time: "_ECRUN 109 W !," End Date: ",ECEND,?97," Threshold Value: ",ECTHLD 110 W !!,?21,"Date of",?43,"PCE CPT/",?112,"Cost of" 111 W !,"Name",?11,"SSN",?21,"Service",?36,"HCPCS CODE & Modifiers" 112 W ?72,"Feeder Key",?93,"Quantity",?110,"Transaction" 113 W !,LN,! 114 Q 115 ; 1 ECXUPRO ;ALB/TJL-Prosthetic Extract Unusual Cost Report ; 7/1/03 1:00pm 2 ;;3.0;DSS EXTRACTS;**49**;July 1, 2003 3 ; 4 EN ; entry point 5 N X,Y,DATE,ECRUN,ECXDESC,ECXSAVE,ECXTL,ECTHLD 6 N ECINST,ECSD,ECSD1,ECSTART,ECED,ECEND,ECXERR,QFLG 7 S QFLG=0 8 S ECINST=$$PDIV^ECXPUTL 9 ; get today's date 10 D NOW^%DTC S DATE=X,Y=$E(%,1,12) D DD^%DT S ECRUN=$P(Y,"@") K %DT 11 D BEGIN Q:QFLG 12 D SELECT Q:QFLG 13 S ECXDESC="Prosthetic Extract Unusual Cost Report" 14 S ECXSAVE("EC*")="" 15 W !!,"This report requires 132-column format." 16 D EN^XUTMDEVQ("PROCESS^ECXUPRO",ECXDESC,.ECXSAVE) 17 I POP W !!,"No device selected...exiting.",! Q 18 I IO'=IO(0) D ^%ZISC 19 D HOME^%ZIS 20 D AUDIT^ECXKILL 21 Q 22 ; 23 BEGIN ; display report description 24 W @IOF 25 W !,"This report prints a listing of unusual costs that would be" 26 W !,"generated by the Prosthetic extract (PRO) as determined by a" 27 W !,"user-defined threshold value. It should be run prior to the" 28 W !,"generation of the actual extract(s) to identify and fix, as" 29 W !,"necessary, any costs determined to be erroneous." 30 W !!,"Unusual costs are those where the Cost of Transaction is" 31 W !,"greater than the threshold value." 32 W !!,"Note: The threshold can be set after a report is selected." 33 W !!,"Run times for this report will vary depending upon the size of" 34 W !,"the extract and could take as long as 30 minutes or more to" 35 W !,"complete. This report has no effect on the actual extracts and" 36 W !,"can be run as needed." 37 W !!,"The report is sorted by Feeder Key, then by descending Cost of" 38 W !,"Transaction and SSN." 39 S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q 40 W:$Y!($E(IOST)="C") @IOF,!! 41 Q 42 ; 43 SELECT ; user inputs for threshold cost and date range 44 N DONE,OUT 45 ; allow user to set threshold cost 46 S ECTHLD=500 47 W !!,"The default threshold cost for the Prosthetic extract is $"_ECTHLD_".00." 48 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 49 I Y D 50 .W !!,"Cost > threshold" 51 .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 52 ; get date range from user 53 W !!,"Enter the date range for which you would like to scan the Prosthetic",!,"Extract records.",! 54 S DONE=0 F S (ECED,ECSD)="" D Q:QFLG!DONE 55 .K %DT S %DT="AEX",%DT("A")="Starting with Date: ",%DT(0)=-DATE D ^%DT 56 .I Y<0 S QFLG=1 Q 57 .S ECSD=Y,ECSD1=ECSD-.1 58 .D DD^%DT S ECSTART=Y 59 .K %DT S %DT="AEX",%DT("A")="Ending with Date: ",%DT(0)=-DATE D ^%DT 60 .I Y<0 S QFLG=1 Q 61 .I Y<ECSD D Q 62 ..W !!,"The ending date cannot be earlier than the starting date." 63 ..W !,"Please try again.",!! 64 .I $E(Y,1,5)'=$E(ECSD,1,5) D Q 65 ..W !!,"Beginning and ending dates must be in the same month and year." 66 ..W !,"Please try again.",!! 67 .S ECED=Y 68 .D DD^%DT S ECEND=Y 69 .S DONE=1 70 Q 71 ; 72 PROCESS ; entry point for queued report 73 S ZTREQ="@" 74 S ECXERR=0 D EN^ECXUPRO1 Q:ECXERR 75 S QFLG=0 D PRINT 76 Q 77 ; 78 PRINT ; process temp file and print report 79 N PG,QFLG,GTOT,LN,COUNT,FKEY,COST,SSN,REC 80 U IO 81 I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ Q 82 S (PG,QFLG,GTOT)=0,$P(LN,"-",132)="" 83 D HEADER Q:QFLG 84 S COUNT=0,FKEY="" 85 F S FKEY=$O(^TMP($J,FKEY)) Q:FKEY=""!QFLG D 86 .S COST="" F S COST=$O(^TMP($J,FKEY,COST)) Q:COST=""!QFLG D 87 ..S SSN="" F S SSN=$O(^TMP($J,FKEY,COST,SSN)) Q:SSN=""!QFLG S REC=^(SSN) D 88 ...S COUNT=COUNT+1 89 ...I $Y+3>IOSL D HEADER Q:QFLG 90 ...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) 91 Q:QFLG 92 I COUNT=0 W !!,?8,"No unusual costs to report for this extract" 93 CLOSE ; 94 I $E(IOST)="C",'QFLG D 95 .S SS=22-$Y F JJ=1:1:SS W ! 96 .S DIR(0)="E" W ! D ^DIR K DIR 97 Q 98 ; 99 HEADER ;header and page control 100 N SS,JJ 101 I $E(IOST)="C" D 102 .S SS=22-$Y F JJ=1:1:SS W ! 103 .I PG>0 S DIR(0)="E" W ! D ^DIR K DIR S:'Y QFLG=1 104 Q:QFLG 105 W:$Y!($E(IOST)="C") @IOF S PG=PG+1 106 W !,"Prosthetic Extract Unusual Cost Report",?124,"Page: "_PG 107 W !,"Start Date: ",ECSTART,?97,"Report Run Date/Time: "_ECRUN 108 W !," End Date: ",ECEND,?97," Threshold Value: ",ECTHLD 109 W !!,?21,"Date of",?43,"PCE CPT/",?112,"Cost of" 110 W !,"Name",?11,"SSN",?21,"Service",?36,"HCPCS CODE & Modifiers" 111 W ?72,"Feeder Key",?93,"Quantity",?110,"Transaction" 112 W !,LN,! 113 Q 114 ; -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXUPRO1.m
r613 r623 1 ECXUPRO1 ;ALB/TJL-Prosthetics Extract Unusual Cost Report; 01/08/082:49pm2 ;;3.0;DSS EXTRACTS;**49,111**;Jul 2, 2003;Build 4 3 4 EN 5 6 7 8 9 10 11 12 GETRECS 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 FILE 38 39 40 41 42 43 44 45 46 47 48 49 50 S ^TMP($J,ECXFEKEY,-PROQTY,SUBDA,PROSSN)=PRONAME_U_PROSSN_U_PRODAY_U_ECXHCPCS_U_ECXFEKEY_U_PROQTY_U_"$"_$FNUMBER(PROCOST,",",2)51 52 53 54 EXIT 1 ECXUPRO1 ;ALB/TJL-Prosthetics Extract Unusual Cost Report; 7/2/03 2:49pm 2 ;;3.0;DSS EXTRACTS;**49**;Jul 2, 2003 3 ; 4 EN ; entry point 5 N COUNT,ECDFN,ECD,PROCOST 6 K ^TMP($J) 7 S COUNT=0 8 S ECD=ECSD1,ECED=ECED+.3 9 D GETRECS 10 Q 11 ; 12 GETRECS ; get records that are over the threshold 13 N PDA,SUBDA,PROLB,PRO0,PROFORM 14 N DIC,DR,DA,DIQ 15 S QFLG=0,ECXLNE=1,ECXED1=ECED+.9999 16 S PDA=ECSD1 17 F S PDA=$O(^RMPR(660,"CT",PDA)) Q:(PDA>ECXED1)!('PDA)!(QFLG=1) D 18 .S SUBDA=0 19 .F S SUBDA=$O(^RMPR(660,"CT",PDA,SUBDA)) Q:('SUBDA)!(QFLG=1) D 20 ..Q:'$D(^RMPR(660,SUBDA,0)) 21 ..S PRO0=^RMPR(660,SUBDA,0) 22 ..S PROLB=$G(^RMPR(660,SUBDA,"LB")) 23 ..K ECXP S DIC="^RMPR(660,",DR=".02;11",DA=SUBDA,DIQ(0)="EI" 24 ..S DIQ="ECXP" D EN^DIQ1 25 ..S ECXDFN=$G(ECXP(660,SUBDA,.02,"I")) 26 ..S PROFORM=$G(ECXP(660,SUBDA,11,"E"))_U_$G(ECXP(660,SUBDA,11,"I")) 27 ..Q:'$$PATDEM^ECXUTL2(ECXDFN,PDA) 28 ..Q:'$$NTEG^ECXPRO1(ECXDFN,.ECXLNE,SUBDA,PRO0,PROLB,ECINST,PROFORM) 29 ..S PROCOST=$P(PRO0,U,16) 30 ..S:PROFORM["-3" PROCOST=$P(PROLB,U,9) 31 ..S:($P(PROFORM,U,2)=11)!($P(PROFORM,U,2)=12) PROCOST=0 32 ..S:PROCOST="" PROCOST=0 33 ..S PROCOST=(PROCOST+.5)\1 34 ..S:PROCOST>999999 PROCOST=999999 35 ..I PROCOST>ECTHLD D FILE 36 Q 37 FILE ; put records in temp file to print later 38 N OK,PROPAT,PRONAME,PROSSN,CPTCODE,ECXFEKEY,PROQTY 39 S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECD,"."),"1;",.PROPAT) 40 I 'OK Q 41 S PRONAME=PROPAT("NAME") 42 S PROSSN=PROPAT("SSN") 43 S PRODAY=$E(PDA,4,5)_"/"_$E(PDA,6,7)_"/"_$E(PDA,2,3) 44 S CPTCODE=$E(ECXHCPCS,1,5) 45 I PROFORM["-3" F ECXLAB="LAB","ORD" D FEEDINFO^ECXPRO2(ECXSRCE,CPTCODE,ECXTYPE,ECXSTAT2,ECXRQST,ECXRCST,ECXLAB) 46 I PROFORM'["-3" S ECXLAB="NONL" D FEEDINFO^ECXPRO2(ECXSRCE,CPTCODE,ECXTYPE,ECXSTAT2,ECXRQST,ECXRCST,ECXLAB) 47 S PROQTY=$P(PRO0,U,7) 48 S:(+PROQTY=0) PROQTY=1 49 S PROQTY=$$RJ^XLFSTR(PROQTY,8,0) 50 S ^TMP($J,ECXFEKEY,-PROQTY,PROSSN)=PRONAME_U_PROSSN_U_PRODAY_U_ECXHCPCS_U_ECXFEKEY_U_PROQTY_U_"$"_$FNUMBER(PROCOST,",",2) 51 S COUNT=COUNT+1 52 I COUNT#100=0 I $$S^ZTLOAD S (ZSTOP,ECXERR)=1 53 Q 54 EXIT S ECXERR=1 Q -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXUSUR.m
r613 r623 1 ECXUSUR ;ALB/TJL-Surgery Extract Unusual Volume Report ; 9/4/07 8:19am 2 ;;3.0;DSS EXTRACTS;**49,71,84,93,105**;July 1, 2003;Build 70 3 ; 4 EN ; entry point 5 N X,Y,DATE,ECRUN,ECXDESC,ECXSAVE,ECXTL,ECTHLD 6 N ECSD,ECSD1,ECSTART,ECED,ECEND,ECXERR,QFLG,ECXFLAG 7 S QFLG=0,ECTHLD="",ECXFLAG=$G(FLAG) 8 ; get today's date 9 D NOW^%DTC S DATE=X,Y=$E(%,1,12) D DD^%DT S ECRUN=$P(Y,"@") K %DT 10 I 'ECXFLAG D BEGIN Q:QFLG 11 D SELECT Q:QFLG 12 S ECXDESC=$S(ECXFLAG:"SUR Volume Report",1:"Surgery Extract Unusual Volume Report") 13 S ECXSAVE("EC*")="" 14 W !!,"This report requires 132-column format." 15 D EN^XUTMDEVQ("PROCESS^ECXUSUR",ECXDESC,.ECXSAVE) 16 I POP W !!,"No device selected...exiting.",! Q 17 I IO'=IO(0) D ^%ZISC 18 D HOME^%ZIS 19 D AUDIT^ECXKILL 20 Q 21 ; 22 BEGIN ; display report description 23 W @IOF 24 W !,"This report prints a listing of unusual volumes that would be" 25 W !,"generated by the Surgery extract (SUR) as determined by a" 26 W !,"user-defined threshold value. It should be run prior to the" 27 W !,"generation of the actual extract(s) to identify and fix, as" 28 W !,"necessary, any volumes determined to be erroneous." 29 W !!,"Unusual volumes are those where either the Operation Time," 30 W !,"Patient Time, Anesthesia Time, Recovery Room Time, OR Clean Time" 31 W !,"or Pt Holding Time field is greater than the threshold value." 32 W !!,"Note: The threshold can be set after a report is selected." 33 W !!,"Run times for this report will vary depending upon the size of" 34 W !,"the extract and could take as long as 30 minutes or more to" 35 W !,"complete. This report has no effect on the actual extracts and" 36 W !,"can be run as needed." 37 W !!,"The report is sorted by descending Volume and Case Number." 38 S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q 39 W:$Y!($E(IOST)="C") @IOF,!! 40 Q 41 ; 42 SELECT ; user inputs for threshold volume and date range 43 N DONE,OUT 44 ; allow user to set threshold volume 45 I 'ECXFLAG D 46 .S ECTHLD=25 47 .W !!,"The default threshold volume for the Surgery extract is "_ECTHLD_"." 48 .W !,"The default threshold volume ("_ECTHLD_") equates to 6 hours." 49 .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 50 .I Y D 51 ..W !!,"Volume > threshold" 52 ..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 53 ; get date range from user 54 Q:QFLG 55 W !!,"Enter the date range for which you would like to scan the" 56 W !,"Surgery Extract records.",! 57 S DONE=0 F S (ECED,ECSD)="" D Q:QFLG!DONE 58 .K %DT S %DT="AEX",%DT("A")="Starting with Date: ",%DT(0)=-DATE D ^%DT 59 .I Y<0 S QFLG=1 Q 60 .S ECSD=Y,ECSD1=ECSD-.1 61 .D DD^%DT S ECSTART=Y 62 .K %DT S %DT="AEX",%DT("A")="Ending with Date: ",%DT(0)=-DATE D ^%DT 63 .I Y<0 S QFLG=1 Q 64 .I Y<ECSD D Q 65 ..W !!,"The ending date cannot be earlier than the starting date." 66 ..W !,"Please try again.",!! 67 .I $E(Y,1,5)'=$E(ECSD,1,5) D Q 68 ..W !!,"Beginning and ending dates must be in the same month and year" 69 ..W !,"Please try again.",!! 70 .S ECED=Y 71 .D DD^%DT S ECEND=Y 72 .S DONE=1 73 Q 74 ; 75 PROCESS ; entry point for queued report 76 S ZTREQ="@" 77 S ECXERR=0 D EN^ECXUSUR1 Q:ECXERR 78 S QFLG=0 D PRINT 79 Q 80 ; 81 PRINT ; process temp file and print report 82 N PG,QFLG,GTOT,LN,COUNT,VOL,SUB,REC 83 U IO 84 I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ Q 85 S (PG,QFLG,GTOT,COUNT)=0,$P(LN,"-",132)="" 86 D HEADER Q:QFLG 87 S VOL=-999999 F S VOL=$O(^TMP($J,VOL)) Q:VOL=""!QFLG D 88 .S SUB="" F S SUB=$O(^TMP($J,VOL,SUB)) Q:SUB=""!QFLG S REC=^(SUB) D 89 ..S COUNT=COUNT+1 90 ..I $Y+3>IOSL D HEADER Q:QFLG 91 ..W !,?1,$P(REC,U),?7,$P(REC,U,2),?18,$P(REC,U,3),?27,$P(REC,U,4) 92 ..W ?34,$P(REC,U,5),?55,$$RJ^XLFSTR($P(REC,U,7),4) 93 ..W ?66,$$RJ^XLFSTR($P(REC,U,11),4),?77,$$RJ^XLFSTR($P(REC,U,9),4) 94 ..W ?86,$$RJ^XLFSTR($P(REC,U,10),4),?93,$$RJ^XLFSTR($P(REC,U,6),4) 95 ..W ?103,$$RJ^XLFSTR($P(REC,U,8),4),?113,$P(REC,U,14) 96 ..W ?117,$P(REC,U,13) 97 Q:QFLG 98 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") 99 CLOSE ; 100 I $E(IOST)="C",'QFLG D 101 .S SS=22-$Y F JJ=1:1:SS W ! 102 .S DIR(0)="E" W ! D ^DIR K DIR 103 Q 104 ; 105 HEADER ;header and page control 106 N SS,JJ 107 I $E(IOST)="C" D 108 .S SS=22-$Y F JJ=1:1:SS W ! 109 .I PG>0 S DIR(0)="E" W ! D ^DIR K DIR S:'Y QFLG=1 110 Q:QFLG 111 W:$Y!($E(IOST)="C") @IOF S PG=PG+1 112 W !,$S(ECXFLAG:"SUR Volume Report",1:"Surgery Extract Unusual Volume Report"),?124,"Page: "_PG 113 W !,"Start Date: ",ECSTART,?97,"Report Run Date/Time: "_ECRUN 114 W !," End Date: ",ECEND I 'ECXFLAG W ?97," Threshold Value: ",ECTHLD 115 W !!,?28,"Case",?38,"Encounter",?52,"Pt Holding",?63,"Anesthesia",?75,"Patient",?83,"Operation",?93,"PACU",?101,"OR Clean",?111,"Canc/",?121,"Principal" 116 W !,?1,"Name",?10,"SSN",?20,"Day",?27,"Number",?40,"Number" 117 W ?54,"Time",?66,"Time",?77,"Time",?86,"Time",?93,"Time",?103,"Time" 118 W ?111,"Abort",?121,"Procedure" 119 W !,LN,! 120 Q 121 ; 1 ECXUSUR ;ALB/TJL-Surgery Extract Unusual Volume Report ; 4/11/06 10:44AM 2 ;;3.0;DSS EXTRACTS;**49,71,84,93**;July 1, 2003 3 ; 4 EN ; entry point 5 N X,Y,DATE,ECRUN,ECXDESC,ECXSAVE,ECXTL,ECTHLD 6 N ECSD,ECSD1,ECSTART,ECED,ECEND,ECXERR,QFLG,ECXFLAG 7 S QFLG=0,ECTHLD="",ECXFLAG=$G(FLAG) 8 ; get today's date 9 D NOW^%DTC S DATE=X,Y=$E(%,1,12) D DD^%DT S ECRUN=$P(Y,"@") K %DT 10 I 'ECXFLAG D BEGIN Q:QFLG 11 D SELECT Q:QFLG 12 S ECXDESC=$S(ECXFLAG:"SUR Volume Report",1:"Surgery Extract Unusual Volume Report") 13 S ECXSAVE("EC*")="" 14 W !!,"This report requires 132-column format." 15 D EN^XUTMDEVQ("PROCESS^ECXUSUR",ECXDESC,.ECXSAVE) 16 I POP W !!,"No device selected...exiting.",! Q 17 I IO'=IO(0) D ^%ZISC 18 D HOME^%ZIS 19 D AUDIT^ECXKILL 20 Q 21 ; 22 BEGIN ; display report description 23 W @IOF 24 W !,"This report prints a listing of unusual volumes that would be" 25 W !,"generated by the Surgery extract (SUR) as determined by a" 26 W !,"user-defined threshold value. It should be run prior to the" 27 W !,"generation of the actual extract(s) to identify and fix, as" 28 W !,"necessary, any volumes determined to be erroneous." 29 W !!,"Unusual volumes are those where either the Operation Time," 30 W !,"Patient Time, Anesthesia Time, Recovery Room Time, OR Clean Time" 31 W !,"or Pt Holding Time field is greater than the threshold value." 32 W !!,"Note: The threshold can be set after a report is selected." 33 W !!,"Run times for this report will vary depending upon the size of" 34 W !,"the extract and could take as long as 30 minutes or more to" 35 W !,"complete. This report has no effect on the actual extracts and" 36 W !,"can be run as needed." 37 W !!,"The report is sorted by descending Volume and Case Number." 38 S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q 39 W:$Y!($E(IOST)="C") @IOF,!! 40 Q 41 ; 42 SELECT ; user inputs for threshold volume and date range 43 N DONE,OUT 44 ; allow user to set threshold volume 45 I 'ECXFLAG D 46 .S ECTHLD=25 47 .W !!,"The default threshold volume for the Surgery extract is "_ECTHLD_"." 48 .W !,"The default threshold volume ("_ECTHLD_") equates to 6 hours." 49 .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 50 .I Y D 51 ..W !!,"Volume > threshold" 52 ..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 53 ; get date range from user 54 Q:QFLG 55 W !!,"Enter the date range for which you would like to scan the" 56 W !,"Surgery Extract records.",! 57 S DONE=0 F S (ECED,ECSD)="" D Q:QFLG!DONE 58 .K %DT S %DT="AEX",%DT("A")="Starting with Date: ",%DT(0)=-DATE D ^%DT 59 .I Y<0 S QFLG=1 Q 60 .S ECSD=Y,ECSD1=ECSD-.1 61 .D DD^%DT S ECSTART=Y 62 .K %DT S %DT="AEX",%DT("A")="Ending with Date: ",%DT(0)=-DATE D ^%DT 63 .I Y<0 S QFLG=1 Q 64 .I Y<ECSD D Q 65 ..W !!,"The ending date cannot be earlier than the starting date." 66 ..W !,"Please try again.",!! 67 .I $E(Y,1,5)'=$E(ECSD,1,5) D Q 68 ..W !!,"Beginning and ending dates must be in the same month and year" 69 ..W !,"Please try again.",!! 70 .S ECED=Y 71 .D DD^%DT S ECEND=Y 72 .S DONE=1 73 Q 74 ; 75 PROCESS ; entry point for queued report 76 S ZTREQ="@" 77 S ECXERR=0 D EN^ECXUSUR1 Q:ECXERR 78 S QFLG=0 D PRINT 79 Q 80 ; 81 PRINT ; process temp file and print report 82 N PG,QFLG,GTOT,LN,COUNT,VOL,SUB,REC 83 U IO 84 I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ Q 85 S (PG,QFLG,GTOT,COUNT)=0,$P(LN,"-",132)="" 86 D HEADER Q:QFLG 87 S VOL=-999999 F S VOL=$O(^TMP($J,VOL)) Q:VOL=""!QFLG D 88 .S SUB="" F S SUB=$O(^TMP($J,VOL,SUB)) Q:SUB=""!QFLG S REC=^(SUB) D 89 ..S COUNT=COUNT+1 90 ..I $Y+3>IOSL D HEADER Q:QFLG 91 ..W !,$P(REC,U),?6,$P(REC,U,2),?17,$P(REC,U,3),?26,$P(REC,U,4) 92 ..W ?33,$P(REC,U,5),?55,$$RJ^XLFSTR($P(REC,U,9),4) 93 ..W ?63,$$RJ^XLFSTR($P(REC,U,10),4),?74,$$RJ^XLFSTR($P(REC,U,11),4) 94 ..W ?83,$$RJ^XLFSTR($P(REC,U,6),4),?90,$$RJ^XLFSTR($P(REC,U,8),4) 95 ..W ?101,$$RJ^XLFSTR($P(REC,U,7),4),?114,$P(REC,U,13) 96 Q:QFLG 97 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") 98 CLOSE ; 99 I $E(IOST)="C",'QFLG D 100 .S SS=22-$Y F JJ=1:1:SS W ! 101 .S DIR(0)="E" W ! D ^DIR K DIR 102 Q 103 ; 104 HEADER ;header and page control 105 N SS,JJ 106 I $E(IOST)="C" D 107 .S SS=22-$Y F JJ=1:1:SS W ! 108 .I PG>0 S DIR(0)="E" W ! D ^DIR K DIR S:'Y QFLG=1 109 Q:QFLG 110 W:$Y!($E(IOST)="C") @IOF S PG=PG+1 111 W !,$S(ECXFLAG:"SUR Volume Report",1:"Surgery Extract Unusual Volume Report"),?124,"Page: "_PG 112 W !,"Start Date: ",ECSTART,?97,"Report Run Date/Time: "_ECRUN 113 W !," End Date: ",ECEND I 'ECXFLAG W ?97," Threshold Value: ",ECTHLD 114 W !!,?27,"Case",?37,"Encounter",?53,"Patient",?61,"Operation",?71,"Anesthesia",?83,"PACU",?89,"OR Clean",?99,"Pt Holding",?114,"Principal" 115 W !,"Name",?9,"SSN",?19,"Day",?26,"Number",?39,"Number" 116 W ?55,"Time",?63,"Time",?74,"Time",?83,"Time",?90,"Time",?101,"Time" 117 W ?114,"Procedure" 118 W !,LN,! 119 Q 120 ; -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXUSUR1.m
r613 r623 1 ECXUSUR1 ;ALB/TJL-Surgery Extract Unusual Volume Report ; 1/8/08 9:58am 2 ;;3.0;DSS EXTRACTS;**49,71,105,111**;July 1, 2003;Build 4 3 EN ; 4 N ECHEAD,COUNT,TIMEDIF,ECXPROC 5 S ECHEAD="SUR" 6 S (COUNT,QFLG)=0,ECED=ECED+.3,ECD=ECSD1 7 F S ECD=$O(^SRF("AC",ECD)) Q:('ECD)!(ECD>ECED)!(QFLG) D 8 .S ECD0=0 9 .F S ECD0=$O(^SRF("AC",ECD,ECD0)) Q:'ECD0 D 10 ..I $D(^SRF(ECD0,0)) S ECXDFN=+$P(^(0),U,1) D STUFF Q:QFLG 11 Q 12 ; 13 STUFF ;gather data 14 N J,DATA1,DATA2,DATAOP,ECXNONL,ECXSTOP 15 S ECXDATE=ECD,ECXERR=0,ECXQ="" 16 Q:'$$PATDEM^ECXUTL2(ECXDFN,ECXDATE,"1;2;3;5;") 17 S EC0=^SRF(ECD0,0) 18 S DATA1=$S($D(^SRF(ECD0,.1)):^(.1),1:"") 19 S DATA2=$S($D(^SRF(ECD0,.2)):^(.2),1:"") 20 S DATAOP=$S($D(^SRF(ECD0,"OP")):^("OP"),1:"") 21 S DATAPA=$S($D(^SRF(ECD0,1.1)):^(1.1),1:"") 22 S ECNO=$G(^SRF(ECD0,"NON")) 23 ;get data 24 S ECSS=$P($G(^SRO(137.45,+$P(EC0,U,4),0)),U,2) 25 S ECSS=$$RJ^XLFSTR($P($G(^DIC(45.3,+ECSS,0)),U),3,0) 26 S:ECSS="000" ECSS="999" 27 ;look for non-OR 28 S (ECNT,ECNL,ECXNONL,ECXSTOP)="" 29 I $P(ECNO,U)="Y" D 30 .S A1=$P(ECNO,U,5) 31 .S A2=$P(ECNO,U,4) 32 .S TIME="##" 33 .D:(A1&A2) TIME S ECNT=TIME 34 .S ECXNONL=+$P(ECNO,U,2) 35 .S ECNL=$P($G(^ECX(728.44,ECXNONL,0)),U,9) 36 .I ECNL="" S ECNL="UNKNOWN" 37 .; 38 .; Get DSS Stop Code to use in encounter number 39 .S ECXSTOP=$P($G(^ECX(728.44,ECXNONL,0)),U,4) 40 ; 41 ;retrieving anesthesia times first, then operation and patient 42 ;times, then storing in following order: 43 ;ecode0="recovery room time^pt hold area time^or clean time^patient 44 ;time^operation time^anesthesia time 45 S ECODE0="" 46 F J="1,4","2,3","10,12","13,14","15,10" D 47 .S A2=$P(DATA2,U,$P(J,",")) 48 .S A1=$P(DATA2,U,$P(J,",",2)) 49 .S TIME="##" 50 .I (A1&A2) D TIMEDIF(A1,A2) D 51 ..I +J'=2 D TIME 52 ..I +J=2 D ;-Operation Time 53 ...S TIME=$TR($J(TIMEDIF,4,0)," ") 54 ...;I TIME<0 S TIME="###" 55 .S ECODE0=TIME_U_ECODE0 K TIME 56 ; 57 ;retrieve recovery room (PACU) time 58 S A2=$P($G(DATAPA),U,7) 59 S A1=$P($G(DATAPA),U,8) 60 S TIME="##" 61 I (A1&A2) D TIME 62 S ECODE0=TIME_U_ECODE0 K TIME 63 ; 64 I ECNL]"" S $P(ECODE0,U,2)=ECNT 65 ; 66 ;- Was surgery cancelled/aborted 67 S ECCAN=$P($G(^SRF(ECD0,30)),U) 68 I +ECCAN S ECCAN=$$CANC^ECXUTL4(ECNL,$P(DATA2,U,10)) 69 ; 70 I ECXFLAG D FILE Q 71 N PIECE,FILE 72 S FILE="NO" 73 F PIECE=1,2,3,4,5,6 D 74 . I $P(ECODE0,U,PIECE)>ECTHLD S FILE="YES" 75 . I $P(ECODE0,U,PIECE)<0 S FILE="YES" 76 ; 77 I FILE="YES" D FILE Q:ECXERR 78 Q 79 ; 80 FILE ; Store unusual records for display later 81 N OK,SURPAT,SURNAME,SURSSN,SURDT,VOL 82 S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECD,"."),"1;",.SURPAT) 83 I 'OK Q 84 S SURNAME=SURPAT("NAME") 85 S SURSSN=SURPAT("SSN") 86 S SURDT=$E(ECXDATE,4,5)_"/"_$E(ECXDATE,6,7)_"/"_$E(ECXDATE,2,3) 87 ; 88 ; Observation Patient Indicator (yes/no) 89 S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECNL) 90 ; 91 ; Principal Procedure 92 S ECXPROC=$E($P(DATAOP,U),1,15) 93 ; 94 ; If no encounter number don't file record 95 S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXSTOP,ECSS) Q:ECXENC="" 96 ; 97 S VOL=$P(ECODE0,U) 98 I $P(ECODE0,U,2)>VOL S VOL=$P(ECODE0,U,2) 99 I $P(ECODE0,U,3)>VOL S VOL=$P(ECODE0,U,3) 100 S ^TMP($J,-VOL,-ECD0)=SURNAME_U_SURSSN_U_SURDT_U_ECD0_U_ECXENC_U_ECODE0_U_ECXPROC_U_ECCAN 101 S COUNT=COUNT+1 102 I COUNT#100=0 I $$S^ZTLOAD S (ZSTOP,ECXERR)=1 103 Q 104 ; 105 TIME ; given date/time get increment 106 N CON 107 S CON=$P($G(^SRF(ECD0,"CON")),U) 108 D TIMEDIF(A1,A2) 109 I 'CON D 110 .S TIME=$J($TR($J(TIMEDIF,4,0)," "),2,1) 111 .S:TIME>"99.0" TIME="99.0" 112 I CON D 113 .S TIME=$J(($TR($J(TIMEDIF,4,0)," ")/2),2,1) 114 .S:TIME>"99.5" TIME="99.5" 115 ;S:TIME<0 TIME="###" 116 Q 117 ; 118 TIMEDIF(START,FINISH) ; Set values to be compared, in seconds 119 ; 120 S TIMEDIF=$$FMDIFF^XLFDT(START,FINISH,2)/900 121 I (TIMEDIF>0)&(TIMEDIF<.5) S TIMEDIF=.5 122 Q 123 ; 124 EXIT S ECXERR=1 Q 1 ECXUSUR1 ;ALB/TJL-Surgery Extract Unusual Volume Report ; 12/1/04 4:48pm 2 ;;3.0;DSS EXTRACTS;**49,71**;July 1, 2003 3 EN ; 4 N ECHEAD,COUNT,TIMEDIF,ECXPROC 5 S ECHEAD="SUR" 6 S (COUNT,QFLG)=0,ECED=ECED+.3,ECD=ECSD1 7 F S ECD=$O(^SRF("AC",ECD)) Q:('ECD)!(ECD>ECED)!(QFLG) D 8 .S ECD0=0 9 .F S ECD0=$O(^SRF("AC",ECD,ECD0)) Q:'ECD0 D 10 ..I $D(^SRF(ECD0,0)) S ECXDFN=+$P(^(0),U,1) D STUFF Q:QFLG 11 Q 12 ; 13 STUFF ;gather data 14 N J,DATA1,DATA2,DATAOP,ECXNONL,ECXSTOP 15 S ECXDATE=ECD,ECXERR=0,ECXQ="" 16 Q:'$$PATDEM^ECXUTL2(ECXDFN,ECXDATE,"1;2;3;5;") 17 S EC0=^SRF(ECD0,0) 18 S DATA1=$S($D(^SRF(ECD0,.1)):^(.1),1:"") 19 S DATA2=$S($D(^SRF(ECD0,.2)):^(.2),1:"") 20 S DATAOP=$S($D(^SRF(ECD0,"OP")):^("OP"),1:"") 21 S DATAPA=$S($D(^SRF(ECD0,1.1)):^(1.1),1:"") 22 S ECNO=$G(^SRF(ECD0,"NON")) 23 ;get data 24 S ECSS=$P($G(^SRO(137.45,+$P(EC0,U,4),0)),U,2) 25 S ECSS=$$RJ^XLFSTR($P($G(^DIC(45.3,+ECSS,0)),U),3,0) 26 S:ECSS="000" ECSS="999" 27 ;look for non-OR 28 S (ECNT,ECNL,ECXNONL,ECXSTOP)="" 29 I $P(ECNO,U)="Y" D 30 .S A1=$P(ECNO,U,5) 31 .S A2=$P(ECNO,U,4) 32 .S TIME="##" 33 .D:(A1&A2) TIME S ECNT=TIME 34 .S ECXNONL=+$P(ECNO,U,2) 35 .S ECNL=$P($G(^ECX(728.44,ECXNONL,0)),U,9) 36 .I ECNL="" S ECNL="UNKNOWN" 37 .; 38 .; Get DSS Stop Code to use in encounter number 39 .S ECXSTOP=$P($G(^ECX(728.44,ECXNONL,0)),U,4) 40 ; 41 ;retrieving anesthesia times first, then operation and patient 42 ;times, then storing in following order: 43 ;ecode0="recovery room time^pt hold area time^or clean time^patient 44 ;time^operation time^anesthesia time 45 S ECODE0="" 46 F J="1,4","2,3","10,12","13,14","15,10" D 47 .S A2=$P(DATA2,U,$P(J,",")) 48 .S A1=$P(DATA2,U,$P(J,",",2)) 49 .S TIME="##" 50 .I (A1&A2) D TIMEDIF(A1,A2) D 51 ..I +J'=2 D TIME 52 ..I +J=2 D ;-Operation Time 53 ...S TIME=$TR($J(TIMEDIF,4,0)," ") 54 ...;I TIME<0 S TIME="###" 55 .S ECODE0=TIME_U_ECODE0 K TIME 56 ; 57 ;retrieve recovery room (PACU) time 58 S A2=$P($G(DATAPA),U,7) 59 S A1=$P($G(DATAPA),U,8) 60 S TIME="##" 61 I (A1&A2) D TIME 62 S ECODE0=TIME_U_ECODE0 K TIME 63 ; 64 I ECNL]"" S $P(ECODE0,U,5)=ECNT 65 ; 66 I ECXFLAG D FILE Q 67 N PIECE,FILE 68 S FILE="NO" 69 F PIECE=1,2,3,4,5,6 D 70 . I $P(ECODE0,U,PIECE)>ECTHLD S FILE="YES" 71 . I $P(ECODE0,U,PIECE)<0 S FILE="YES" 72 I FILE="YES" D FILE Q:ECXERR 73 Q 74 ; 75 FILE ; Store unusual records for display later 76 N OK,SURPAT,SURNAME,SURSSN,SURDT,VOL 77 S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECD,"."),"1;",.SURPAT) 78 I 'OK Q 79 S SURNAME=SURPAT("NAME") 80 S SURSSN=SURPAT("SSN") 81 S SURDT=$E(ECXDATE,4,5)_"/"_$E(ECXDATE,6,7)_"/"_$E(ECXDATE,2,3) 82 ; 83 ; Observation Patient Indicator (yes/no) 84 S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECNL) 85 ; 86 ; Principal Procedure 87 S ECXPROC=$E($P(DATAOP,U),1,15) 88 ; 89 ; If no encounter number don't file record 90 S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXSTOP,ECSS) Q:ECXENC="" 91 ; 92 S VOL=$P(ECODE0,U,4) 93 I $P(ECODE0,U,5)>VOL S VOL=$P(ECODE0,U,5) 94 I $P(ECODE0,U,6)>VOL S VOL=$P(ECODE0,U,6) 95 S ^TMP($J,-VOL,-ECD0)=SURNAME_U_SURSSN_U_SURDT_U_ECD0_U_ECXENC_U_ECODE0_U_ECXPROC 96 S COUNT=COUNT+1 97 I COUNT#100=0 I $$S^ZTLOAD S (ZSTOP,ECXERR)=1 98 Q 99 ; 100 TIME ; given date/time get increment 101 N CON 102 S CON=$P($G(^SRF(ECD0,"CON")),U) 103 D TIMEDIF(A1,A2) 104 I 'CON D 105 .S TIME=$J($TR($J(TIMEDIF,4,0)," "),2,1) 106 .S:TIME>"99.0" TIME="99.0" 107 I CON D 108 .S TIME=$J(($TR($J(TIMEDIF,4,0)," ")/2),2,1) 109 .S:TIME>"99.5" TIME="99.5" 110 ;S:TIME<0 TIME="###" 111 Q 112 ; 113 TIMEDIF(START,FINISH) ; Set values to be compared, in seconds 114 ; 115 S TIMEDIF=$$FMDIFF^XLFDT(START,FINISH,2)/900 116 I (TIMEDIF>0)&(TIMEDIF<.5) S TIMEDIF=.5 117 Q 118 ; 119 EXIT S ECXERR=1 Q -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXUTL2.m
r613 r623 1 ECXUTL2 ;ALB/JAP - Utilities for DSS Extracts (cont.) ; 6/12/07 6:38am 2 ;;3.0;DSS EXTRACTS;**8,13,23,24,33,35,39,46,71,84,92,105**;Dec 22, 1997;Build 70 3 ; 4 ECXDEF(ECXHEAD,ECXPACK,ECXGRP,ECXFILE,ECXRTN,ECXPIECE,ECXVER) ;variables specific to extract from file #727.1 5 ; input 6 ; ECXHEAD = extract header code 7 ; all other formal list parameters passed by reference 8 ; output 9 ; ECXPACK = type field (#7) 10 ; ECXGRP = group field (#9) 11 ; ECXFILE = file number field (#1) 12 ; ECXRTN = routine field (#4) 13 ; ECXPIECE= running piece field (#11) 14 ; ECXVER = dss version 15 N ECXIEN,ECXARR,DIC,DA,DR,DIQ 16 S (ECXPACK,ECXGRP,ECXFILE,ECXRTN,ECXPIECE,ECXVER)="",ECXIEN=0 17 S ECXIEN=+$O(^ECX(727.1,"C",ECXHEAD,ECXIEN)) 18 I ECXIEN=0 D Q 19 .D MES^XPDUTL(" ") 20 .D MES^XPDUTL(" It appears that you may have a problem with File #727.1 --") 21 .D MES^XPDUTL(" ") 22 .D MES^XPDUTL(" The "_ECHEAD_" Extract is not properly defined.") 23 .D MES^XPDUTL(" ") 24 .D MES^XPDUTL(" Contact National VISTA Support for further assistance.") 25 .D MES^XPDUTL(" ") 26 .I $E(IOST)="C" D 27 ..S SS=22-$Y F JJ=1:1:SS W ! 28 ..S DIR(0)="E" W ! D ^DIR K DIR 29 .W !! 30 S DIC="^ECX(727.1,",DA=ECXIEN,DR=".01;1;4;7;9;11",DIQ="ECXARR" 31 D EN^DIQ1 32 S ECXPACK=ECXARR(727.1,ECXIEN,7) 33 ;if this is an inactive extract type, skip it 34 I ECXPACK["Inactive" D Q 35 .D MES^XPDUTL(" ") 36 .D MES^XPDUTL(" The "_ECHEAD_" Extract is no longer active/valid.") 37 .D MES^XPDUTL(" ") 38 .D MES^XPDUTL(" Contact National VISTA Support for further assistance.") 39 .D MES^XPDUTL(" ") 40 .I $E(IOST)="C" D 41 ..S SS=22-$Y F JJ=1:1:SS W ! 42 ..S DIR(0)="E" W ! D ^DIR K DIR 43 .W !! 44 S ECXGRP=ECXARR(727.1,ECXIEN,9) 45 S ECXFILE=ECXARR(727.1,ECXIEN,1) 46 S ECXRTN="START^"_ECXARR(727.1,ECXIEN,4) 47 S ECXPIECE=ECXARR(727.1,ECXIEN,11) 48 ;version of dss/tsi in Austin as specified by btso 49 S ECXVER=7 50 Q 51 PATDEM(DFN,DT1,PAR,FLG) ; determine patient information 52 ; DFN = 53 ; DT = 54 ; PAR = 55 ; FLG = 56 N DT2,PAT,OK,X 57 D KPATDEM 58 S FLG=$G(FLG),PAR=$S($D(PAR):PAR,1:"1;2;3;4;5;"),DT2=$P(DT1,".") 59 Q:'$$PAT^ECXUTL3(DFN,DT2,PAR,.PAT) 0 60 S ECXMPI=PAT("MPI") 61 I PAR["1" D 62 .S ECXSSN=PAT("SSN"),ECXPNM=PAT("NAME"),ECXDOB=PAT("DOB") 63 .S ECXSEX=PAT("SEX"),ECXREL=PAT("RELIGION"),ECXRACE=PAT("RACE") 64 .S ECXMAR=PAT("MARITAL") 65 .S ECXETH=PAT("ETHNIC"),ECXRC1=PAT("RACE1") 66 I PAR["2" D 67 .S ECXCNTY=PAT("COUNTY"),ECXSTATE=PAT("STATE"),ECXZIP=PAT("ZIP") 68 I PAR["3" D 69 .S ECXPOS=PAT("POS"),ECSC=PAT("SC STAT"),ECXSVC=PAT("SC%") 70 .S ECXVET=PAT("VET"),ECXMEAN=PAT("MEANS"),ECXELIG=PAT("ELIG") 71 .S ECXENRL=PAT("ENROLL LOC") 72 .S ECXERI=PAT("ERI") 73 I PAR["4" S ECXEMP=PAT("EMPLOY") 74 I PAR["5" D 75 .S ECXVIET=PAT("VIETNAM"),ECXAST=PAT("AO STAT"),ECXRST=PAT("IR STAT") 76 .S ECXEST=PAT("EC STAT"),ECXPST=PAT("POW STAT"),ECXPLOC=PAT("POW LOC") 77 .S ECXPHI=PAT("PHI"),ECXMST=PAT("MST STAT"),ECXAOL=PAT("AOL") 78 .S ECXOEF=PAT("ECXOEF"),ECXOEFDT=PAT("ECXOEFDT") 79 I PAR["6" D 80 .S (ECXPAYOR,ECXSAI)="" D VISN19(DFN,.ECXPAYOR,.ECXSAI) 81 I FLG'[3 D 82 .S X=$$PRIMARY(DFN,DT2),ECPTTM=$P(X,U),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3) 83 .S ECPTNPI=$P(X,U,4),ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6) 84 .S ECASNPI=$P(X,U,7) 85 I FLG'[2 D 86 .S ECXINP=$$INP^ECXUTL2(DFN,DT1),ECXA=$P(ECXINP,U),ECXMN=$P(ECXINP,U,2) 87 .S ECXTS=$P(ECXINP,U,3),ECXDOM=$P(ECXINP,U,10),ECXADMDT=$P(ECXINP,U,4) 88 I FLG'[1 S X=$$ENROLLM(DFN) 89 Q 1 90 ; 91 KPATDEM ; 92 K ECXADMDT,ECAO,ECASNPI,ECASPR,ECCLAS,ECCLAS2,ECENV,ECPTNPI,ECPTPR,ECPTTM 93 K ECRE,ECSC,ECXA,ECXAST,ECXCAT,ECXCNTY,ECXEST,ECXENRL,ECXDOB 94 K ECXDOM,ECXELIG,ECXINP,ECXMPI,ECXMN,ECXNM,ECXPHI,ECXPLOC,ECXMEAN,ECXMST 95 K ECXPAYOR,ECXPNM,ECXPOS,ECXPRIOR,ECXPST,ECXRACE,ECXREL,ECXRST,ECXSAI 96 K ECXSEX,ECXSSN,ECXSTAT,ECXSTATE,ECXSVC,ECXTS,ECXVIET,ECXZIP,VA,VAERR 97 K ECXSBGRP 98 Q 99 ENROLLM(DFN,RNDT) ;determines enrollment status, category, priority 100 ;and user enrollee status 101 ; input 102 ; DFN = IEN from Patient file (Required) 103 ; RNDT = Extract Run Date 104 ; output 105 ; ECXSTAT = Enrollment status 106 ; ECXPRIOR = Enrollment priority 107 ; ECXCAT = Enrollment priority 108 ; ECXSBGRP = Enrollment subgroup 109 ; ECXUESTA = User enrollee 110 ; return value 0 if no data found, 1 if data found 111 N CAT,PRIOR,STAT,X,X1,X2,X3,ENRIEN,ENR,FL,SBGRP 112 S (ECXCAT,ECXPRIOR,ECXSTAT,ECXSBGRP,ECXEUSTA)="" 113 I $G(DFN)="" Q 0 114 ;User enrollee status, if current or future date set to 'U' 115 ;DBIA #3989 116 S ECXUESTA=$S($$UESTAT^EASUER(DFN):"U",1:"") 117 ;Patient type 118 S ECXPTYPE=$$TYPE^ECXUTL5(DFN) 119 ;Combat Veteran Status DBIA #4156 120 S X3=$$CVEDT^ECXUTL5(DFN,$S($G(ECD):ECD,$G(ECXDATE):ECXDATE,1:DT)) 121 ;enrollment priority DBIA 122 S STAT=$$STATUS^DGENA(DFN),PRIOR=$$PRIORITY^DGENA(DFN) 123 S CAT=$$CATEGORY^DGENA4(DFN,STAT),SBGRP=$$ENRSBGRP^DGENA4(DFN) 124 ;find current enrollment when status=2 or 19 125 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 126 ;find previous enrollment 127 S ENRIEN=$$FINDCUR^DGENA(DFN) I ENRIEN="" Q 0 128 I $G(RNDT)="" D NOW^%DTC S RNDT=X 129 S RNDT=($E(RNDT,1,3)-1)_$E(RNDT,4,7),FL=0 130 F S ENRIEN=$$FINDPRI^DGENA(ENRIEN) Q:'ENRIEN D Q:FL 131 . S ENR=$$GET^DGENA(ENRIEN,.ENR) 132 . I "^2^19^"[("^"_ENR("STATUS")_"^"),ENR("EFFDATE")>RNDT D 133 . . S ECXSTAT=ENR("STATUS"),ECXPRIOR=PRIOR,FL=1 134 . . S ECXCAT=$$CATEGORY^DGENA4(DFN,ECXSTAT) 135 . . S ECXSBGRP=$$ENRSBGRP^DGENA4(DFN) 136 . . S ECXSBGRP=$S(SBGRP=1:"a",SBGRP=3:"c",SBGRP=5:"e",SBGRP=7:"g",1:"") 137 I FL Q 1 138 ;no enrollment status found =2 or 19 139 S ECXSTAT=STAT,ECXPRIOR=PRIOR,ECXCAT=CAT,ECXSBGRP=$S(SBGRP=1:"a",SBGRP=3:"c",SBGRP=5:"e",SBGRP=7:"g",1:"") 140 Q 1 141 PRIMARY(ECXDFN,ECXDATE,ECXPREFX) ;determine patient's pc team and pc provider 142 ; input 143 ; ECXDFN = file #2 ien (required) 144 ; ECXDATE = date of interest (required) 145 ; ECXPREFX = prefix for provider data (optional) 146 ; defaults to "2" if not specified otherwise 147 ; output 148 ; ECXPRIME = pc team ien^prefix_pc provider ien^pc provider person 149 ;class^pc provider npi^prefix_assoc pc provider ien^assoc pc provider 150 ;person class^assoc pc provider npi 151 N ECPTTM,ECPTPR,ECCLAS,ECPRIME,ECASPR,ECCLAS2 152 S:'$D(ECXPREFX) ECXPREFX=2 S:(+ECXPREFX=0) ECXPREFX=2 153 ;get pc team data 154 S ECPTTM=+$$OUTPTTM^SDUTL3(ECXDFN,ECXDATE) S:ECPTTM=0 ECPTTM="" 155 ;get primary pc provider data 156 S ECPTPR=+$$OUTPTPR^SDUTL3(ECXDFN,ECXDATE) 157 S ECCLAS="" I ECPTPR>0 S ECCLAS=$$PRVCLASS^ECXUTL(ECPTPR,ECXDATE) 158 N ECXUSRTN S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",ECPTPR,ECXDATE) 159 S:+ECXUSRTN'>0 ECXUSRTN="" S ECPTNPI=$P(ECXUSRTN,U) 160 S:ECPTPR=0 ECPTPR="" S:ECPTPR]"" ECPTPR=ECXPREFX_ECPTPR 161 ;assoc pc provider call ok if routine scapmca from patch177 is present 162 S ECASPR="" 163 S X="SCAPMCA" X ^%ZOSF("TEST") I $T D 164 .S ECASPR=+$$OUTPTAP^SDUTL3(ECXDFN,ECXDATE) 165 S ECCLAS2="" I ECASPR>0 S ECCLAS2=$$PRVCLASS^ECXUTL(ECASPR,ECXDATE) 166 N ECXUSRTN S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",ECASPR,ECXDATE) 167 S:+ECXUSRTN'>0 ECXUSRTN="" S ECASNPI=$P(ECXUSRTN,U) 168 S:ECASPR=0 ECASPR="" S:ECASPR]"" ECASPR=ECXPREFX_ECASPR 169 ;assemble 170 S ECXPRIME=ECPTTM_U_ECPTPR_U_ECCLAS_U_ECPTNPI_U_ECASPR_U_ECCLAS2_U_ECASNPI 171 Q ECXPRIME 172 INP(ECXDFN,ECXDATE) ; check for inpatient status 173 ; input 174 ; ECXDFN = file #2 ien (required) 175 ; ECXDATE = date of interest (required) 176 ; output 177 ; ECXINP = patient status^movment # (file #405 ien) 178 ; current treat. spec. (file #42.4 ien)^admission date/time^ 179 ; current ward (file #42 ien)^discharge date/time^ 180 ; ward provider^attending phys.^ward (file #44 ien);facility 181 ; (file #40.8 ien);dss dept^dom 182 ; where patient status = I for inpatient 183 ; = O for outpatient 184 N DFN,DSSDEPT,ECA,ECADM,ECMN,ECTS,ECWARD,ECDC,ECXINP,ECXPRO 185 N ECXATP,ECXDD,ECXDOM,ECXPROF,ECXPWP,ECXWW,FAC,VAIP,WRD,ECXPWPPC 186 N ECXATPPC 187 D FIELD^DID(405,.19,,"SPECIFIER","ECXDD") 188 S ECXPROF=$E(+$P(ECXDD("SPECIFIER"),"P",2)) K ECXDD 189 ;- Inpat/outpat indicator (ECA) initially set to "O" (outpatient) 190 S DFN=ECXDFN,ECA="O" 191 S (DSSDEPT,ECMN,ECTS,ECADM,ECWARD,ECDC,ECXATP,ECXPWP,ECXWW,WRD,FAC,ECXPWPPC,ECXATPPC)="" 192 S VAIP("D")=ECXDATE D IN5^VADPT 193 S ECMN=$G(VAIP(1)) 194 I ECMN D 195 .S ECTS=+$P($G(^DIC(45.7,+VAIP(8),0)),U,2) S:ECTS=0 ECTS="" 196 .;- Get inpat/outpat indicator 197 .S ECA=$$INOUTP^ECXUTL4(ECTS) 198 .S ECADM=+$G(VAIP(13,1)) S:ECADM=0 ECADM="" 199 .S ECWARD=+$G(VAIP(5)) S:ECWARD=0 ECWARD="" 200 .I ECWARD D 201 ..S WRD=+$P($G(^DIC(42,+ECWARD,44)),U) 202 ..S FAC=$P($G(^DIC(42,+ECWARD,0)),U,11) 203 ..S DSSDEPT=$P($G(^ECX(727.4,ECWARD,0)),U,2) 204 .S ECXWW=WRD_";"_FAC_";"_DSSDEPT,ECDC=+$G(VAIP(17,1)) S:ECDC=0 ECDC="" 205 .S ECXPWP=+VAIP(7) S:ECXPWP=0 ECXPWP="" 206 .S ECXATP=+VAIP(18) S:ECXATP=0 ECXATP="" 207 .S ECXPWPPC=$$PRVCLASS^ECXUTL(ECXPWP,ECADM) 208 .S ECXATPPC=$$PRVCLASS^ECXUTL(ECXATP,ECADM) 209 .;prefix file #200 iens 210 .S:ECXPWP ECXPWP=ECXPROF_ECXPWP S:ECXATP ECXATP=ECXPROF_ECXATP 211 S ECXDOM=$P($G(^ECX(727.831,+ECTS,0)),U,2) 212 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 213 Q ECXINP 214 VISN19(ECXDFN,ECXPAYOR,ECXSAI) ;visn 19 sharing agreement data 215 ; input ECXDFN = patient file ien 216 ; output ECXPAYOR, ECXSAI (passed by reference) 217 N JJ,ALIAS,INSUR,DIC,DIQ,DA,DR,ECXARY,ECXERR,ECXDA 218 S (ECXPAYOR,ECXSAI)="" 219 D GETS^DIQ(2,ECXDFN,"1*,","I","ECXARY","ECXERR") 220 I $D(ECXERR) Q 221 S JJ=0 F S JJ=$O(ECXARY(2.01,JJ)) Q:JJ="" D I ECXPAYOR]"" Q 222 . S ALIAS=$G(ECXARY(2.01,JJ,.01,"I")) 223 . 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:"") 224 . W !,$G(CNT)+1 225 . W !,"The value of ECXPAYOR is: ",ECXPAYOR 226 ;K ECXARY,ECXERR 227 I ECXPAYOR]"" D GETS^DIQ(2,ECXDFN,".3121*,","I","ECXARY","ECXERR") D 228 . I $D(ECXERR) Q 229 . S JJ=0,ECXDA=$O(ECXARY(2.312,JJ)) I ECXDA="" Q 230 . S DA=$G(ECXARY(2.312,ECXDA,.01,"I")) I DA="" Q 231 . S INSUR=$$GET1^DIQ(36,DA,".01","I","","ECXERR") 232 . I '$D(ECXERR) S ECXSAI=$E(ECXARY(2.312,ECXDA,.01,"I"),1,11) 233 Q 1 ECXUTL2 ;ALB/JAP - Utilities for DSS Extracts (cont.) ; 11/2/06 9:03am 2 ;;3.0;DSS EXTRACTS;**8,13,23,24,33,35,39,46,71,84,92**;Dec 22, 1997;Build 30 3 ; 4 ECXDEF(ECXHEAD,ECXPACK,ECXGRP,ECXFILE,ECXRTN,ECXPIECE,ECXVER) ;variables specific to extract from file #727.1 5 ; input 6 ; ECXHEAD = extract header code 7 ; all other formal list parameters passed by reference 8 ; output 9 ; ECXPACK = type field (#7) 10 ; ECXGRP = group field (#9) 11 ; ECXFILE = file number field (#1) 12 ; ECXRTN = routine field (#4) 13 ; ECXPIECE= running piece field (#11) 14 ; ECXVER = dss version 15 ; 16 N ECXIEN,ECXARR,DIC,DA,DR,DIQ 17 S (ECXPACK,ECXGRP,ECXFILE,ECXRTN,ECXPIECE,ECXVER)="",ECXIEN=0 18 S ECXIEN=+$O(^ECX(727.1,"C",ECXHEAD,ECXIEN)) 19 I ECXIEN=0 D Q 20 .D MES^XPDUTL(" ") 21 .D MES^XPDUTL(" It appears that you may have a problem with File #727.1 --") 22 .D MES^XPDUTL(" ") 23 .D MES^XPDUTL(" The "_ECHEAD_" Extract is not properly defined.") 24 .D MES^XPDUTL(" ") 25 .D MES^XPDUTL(" Contact National VISTA Support for further assistance.") 26 .D MES^XPDUTL(" ") 27 .I $E(IOST)="C" D 28 ..S SS=22-$Y F JJ=1:1:SS W ! 29 ..S DIR(0)="E" W ! D ^DIR K DIR 30 .W !! 31 S DIC="^ECX(727.1,",DA=ECXIEN,DR=".01;1;4;7;9;11",DIQ="ECXARR" 32 D EN^DIQ1 33 S ECXPACK=ECXARR(727.1,ECXIEN,7) 34 ;if this is an inactive extract type, skip it 35 I ECXPACK["Inactive" D Q 36 .D MES^XPDUTL(" ") 37 .D MES^XPDUTL(" The "_ECHEAD_" Extract is no longer active/valid.") 38 .D MES^XPDUTL(" ") 39 .D MES^XPDUTL(" Contact National VISTA Support for further assistance.") 40 .D MES^XPDUTL(" ") 41 .I $E(IOST)="C" D 42 ..S SS=22-$Y F JJ=1:1:SS W ! 43 ..S DIR(0)="E" W ! D ^DIR K DIR 44 .W !! 45 S ECXGRP=ECXARR(727.1,ECXIEN,9) 46 S ECXFILE=ECXARR(727.1,ECXIEN,1) 47 S ECXRTN="START^"_ECXARR(727.1,ECXIEN,4) 48 S ECXPIECE=ECXARR(727.1,ECXIEN,11) 49 ;version of dss/tsi in Austin as specified by btso 50 S ECXVER=7 51 Q 52 ; 53 PATDEM(DFN,DT1,PAR,FLG) ; determine patient information 54 ; DFN = 55 ; DT = 56 ; PAR = 57 ; FLG = 58 N DT2,PAT,OK,X 59 D KPATDEM 60 S FLG=$G(FLG),PAR=$S($D(PAR):PAR,1:"1;2;3;4;5;"),DT2=$P(DT1,".") 61 Q:'$$PAT^ECXUTL3(DFN,DT2,PAR,.PAT) 0 62 S ECXMPI=PAT("MPI") 63 I PAR["1" D 64 .S ECXSSN=PAT("SSN"),ECXPNM=PAT("NAME"),ECXDOB=PAT("DOB") 65 .S ECXSEX=PAT("SEX"),ECXREL=PAT("RELIGION"),ECXRACE=PAT("RACE") 66 .S ECXMAR=PAT("MARITAL") 67 .S ECXETH=PAT("ETHNIC"),ECXRC1=PAT("RACE1") 68 I PAR["2" D 69 .S ECXCNTY=PAT("COUNTY"),ECXSTATE=PAT("STATE"),ECXZIP=PAT("ZIP") 70 I PAR["3" D 71 .S ECXPOS=PAT("POS"),ECSC=PAT("SC STAT"),ECXSVC=PAT("SC%") 72 .S ECXVET=PAT("VET"),ECXMEAN=PAT("MEANS"),ECXELIG=PAT("ELIG") 73 .S ECXENRL=PAT("ENROLL LOC") 74 .S ECXERI=PAT("ERI") 75 I PAR["4" S ECXEMP=PAT("EMPLOY") 76 I PAR["5" D 77 .S ECXVIET=PAT("VIETNAM"),ECXAST=PAT("AO STAT"),ECXRST=PAT("IR STAT") 78 .S ECXEST=PAT("EC STAT"),ECXPST=PAT("POW STAT"),ECXPLOC=PAT("POW LOC") 79 .S ECXPHI=PAT("PHI"),ECXMST=PAT("MST STAT"),ECXAOL=PAT("AOL") 80 I PAR["6" D 81 .S (ECXPAYOR,ECXSAI)="" D VISN19(DFN,.ECXPAYOR,.ECXSAI) 82 I FLG'[3 D 83 .S X=$$PRIMARY(DFN,DT2),ECPTTM=$P(X,U),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3) 84 .S ECPTNPI=$P(X,U,4),ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6) 85 .S ECASNPI=$P(X,U,7) 86 I FLG'[2 D 87 .S ECXINP=$$INP^ECXUTL2(DFN,DT1),ECXA=$P(ECXINP,U),ECXMN=$P(ECXINP,U,2) 88 .S ECXTS=$P(ECXINP,U,3),ECXDOM=$P(ECXINP,U,10),ECXADMDT=$P(ECXINP,U,4) 89 I FLG'[1 S X=$$ENROLLM(DFN) 90 Q 1 91 ; 92 KPATDEM ; 93 K ECXADMDT,ECAO,ECASNPI,ECASPR,ECCLAS,ECCLAS2,ECENV,ECPTNPI,ECPTPR,ECPTTM 94 K ECRE,ECSC,ECXA,ECXAST,ECXCAT,ECXCNTY,ECXEST,ECXENRL,ECXDOB 95 K ECXDOM,ECXELIG,ECXINP,ECXMPI,ECXMN,ECXNM,ECXPHI,ECXPLOC,ECXMEAN,ECXMST 96 K ECXPAYOR,ECXPNM,ECXPOS,ECXPRIOR,ECXPST,ECXRACE,ECXREL,ECXRST,ECXSAI 97 K ECXSEX,ECXSSN,ECXSTAT,ECXSTATE,ECXSVC,ECXTS,ECXVIET,ECXZIP,VA,VAERR 98 K ECXSBGRP 99 Q 100 ; 101 ENROLLM(DFN,RNDT) ;determines enrollment status, category, priority 102 ;and user enrollee status 103 ; input 104 ; DFN = IEN from Patient file (Required) 105 ; RNDT = Extract Run Date 106 ; output 107 ; ECXSTAT = Enrollment status 108 ; ECXPRIOR = Enrollment priority 109 ; ECXCAT = Enrollment priority 110 ; ECXSBGRP = Enrollment subgroup 111 ; ECXUESTA = User enrollee 112 ; return value 0 if no data found, 1 if data found 113 ; 114 N CAT,PRIOR,STAT,X,X1,X2,X3,ENRIEN,ENR,FL,SBGRP 115 S (ECXCAT,ECXPRIOR,ECXSTAT,ECXSBGRP,ECXEUSTA)="" 116 I $G(DFN)="" Q 0 117 ;User enrollee status, if current or future date set to 'U' 118 ;DBIA #3989 119 S ECXUESTA=$S($$UESTAT^EASUER(DFN):"U",1:"") 120 ;Patient type 121 S ECXPTYPE=$$TYPE^ECXUTL5(DFN) 122 ;Combat Veteran Status DBIA #4156 123 S X3=$$CVEDT^ECXUTL5(DFN,$S($G(ECD):ECD,$G(ECXDATE):ECXDATE,1:DT)) 124 ;enrollment priority DBIA 125 S STAT=$$STATUS^DGENA(DFN),PRIOR=$$PRIORITY^DGENA(DFN) 126 S CAT=$$CATEGORY^DGENA4(DFN,STAT),SBGRP=$$ENRSBGRP^DGENA4(DFN) 127 ;find current enrollment when status=2 or 19 128 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 129 ;find previous enrollment 130 S ENRIEN=$$FINDCUR^DGENA(DFN) I ENRIEN="" Q 0 131 I $G(RNDT)="" D NOW^%DTC S RNDT=X 132 S RNDT=($E(RNDT,1,3)-1)_$E(RNDT,4,7),FL=0 133 F S ENRIEN=$$FINDPRI^DGENA(ENRIEN) Q:'ENRIEN D Q:FL 134 . S ENR=$$GET^DGENA(ENRIEN,.ENR) 135 . I "^2^19^"[("^"_ENR("STATUS")_"^"),ENR("EFFDATE")>RNDT D 136 . . S ECXSTAT=ENR("STATUS"),ECXPRIOR=PRIOR,FL=1 137 . . S ECXCAT=$$CATEGORY^DGENA4(DFN,ECXSTAT) 138 . . S ECXSBGRP=$$ENRSBGRP^DGENA4(DFN) 139 . . S ECXSBGRP=$S(SBGRP=1:"a",SBGRP=3:"c",SBGRP=5:"e",SBGRP=7:"g",1:"") 140 I FL Q 1 141 ;no enrollment status found =2 or 19 142 S ECXSTAT=STAT,ECXPRIOR=PRIOR,ECXCAT=CAT,ECXSBGRP=$S(SBGRP=1:"a",SBGRP=3:"c",SBGRP=5:"e",SBGRP=7:"g",1:"") 143 Q 1 144 ; 145 PRIMARY(ECXDFN,ECXDATE,ECXPREFX) ;determine patient's pc team and pc provider 146 ; input 147 ; ECXDFN = file #2 ien (required) 148 ; ECXDATE = date of interest (required) 149 ; ECXPREFX = prefix for provider data (optional) 150 ; defaults to "2" if not specified otherwise 151 ; output 152 ; ECXPRIME = pc team ien^prefix_pc provider ien^pc provider person class^pc provider npi 153 ; ^prefix_assoc pc provider ien^assoc pc provider person class^assoc pc provider npi 154 ; 155 N ECPTTM,ECPTPR,ECCLAS,ECPRIME,ECASPR,ECCLAS2 156 S:'$D(ECXPREFX) ECXPREFX=2 S:(+ECXPREFX=0) ECXPREFX=2 157 ;get pc team data 158 S ECPTTM=+$$OUTPTTM^SDUTL3(ECXDFN,ECXDATE) S:ECPTTM=0 ECPTTM="" 159 ;get primary pc provider data 160 S ECPTPR=+$$OUTPTPR^SDUTL3(ECXDFN,ECXDATE) 161 S ECCLAS="" I ECPTPR>0 S ECCLAS=$$PRVCLASS^ECXUTL(ECPTPR,ECXDATE) 162 S:ECPTPR=0 ECPTPR="" S:ECPTPR]"" ECPTPR=ECXPREFX_ECPTPR 163 S ECPTNPI="" 164 ;assoc pc provider call ok if routine scapmca from patch177 is present 165 S ECASPR="" 166 S X="SCAPMCA" X ^%ZOSF("TEST") I $T D 167 .S ECASPR=+$$OUTPTAP^SDUTL3(ECXDFN,ECXDATE) 168 S ECCLAS2="" I ECASPR>0 S ECCLAS2=$$PRVCLASS^ECXUTL(ECASPR,ECXDATE) 169 S:ECASPR=0 ECASPR="" S:ECASPR]"" ECASPR=ECXPREFX_ECASPR 170 S ECASNPI="" 171 ;assemble 172 S ECXPRIME=ECPTTM_U_ECPTPR_U_ECCLAS_U_ECPTNPI_U_ECASPR_U_ECCLAS2_U_ECASNPI 173 Q ECXPRIME 174 ; 175 INP(ECXDFN,ECXDATE) ; check for inpatient status 176 ; input 177 ; ECXDFN = file #2 ien (required) 178 ; ECXDATE = date of interest (required) 179 ; output 180 ; ECXINP = patient status^movment # (file #405 ien) 181 ; current treat. spec. (file #42.4 ien)^admission date/time^ 182 ; current ward (file #42 ien)^discharge date/time^ 183 ; ward provider^attending phys.^ward (file #44 ien);facility 184 ; (file #40.8 ien);dss dept^dom 185 ; where patient status = I for inpatient 186 ; = O for outpatient 187 ; 188 N DFN,DSSDEPT,ECA,ECADM,ECMN,ECTS,ECWARD,ECDC,ECXINP,ECXPRO 189 N ECXATP,ECXDD,ECXDOM,ECXPROF,ECXPWP,ECXWW,FAC,VAIP,WRD,ECXPWPPC 190 N ECXATPPC 191 D FIELD^DID(405,.19,,"SPECIFIER","ECXDD") 192 S ECXPROF=$E(+$P(ECXDD("SPECIFIER"),"P",2)) K ECXDD 193 ; 194 ;- Inpat/outpat indicator (ECA) initially set to "O" (outpatient) 195 S DFN=ECXDFN,ECA="O" 196 S (DSSDEPT,ECMN,ECTS,ECADM,ECWARD,ECDC,ECXATP,ECXPWP,ECXWW,WRD,FAC,ECXPWPPC,ECXATPPC)="" 197 S VAIP("D")=ECXDATE D IN5^VADPT 198 S ECMN=$G(VAIP(1)) 199 I ECMN D 200 .S ECTS=+$P($G(^DIC(45.7,+VAIP(8),0)),U,2) S:ECTS=0 ECTS="" 201 .; 202 .;- Get inpat/outpat indicator 203 .S ECA=$$INOUTP^ECXUTL4(ECTS) 204 .S ECADM=+$G(VAIP(13,1)) S:ECADM=0 ECADM="" 205 .S ECWARD=+$G(VAIP(5)) S:ECWARD=0 ECWARD="" 206 .I ECWARD D 207 ..S WRD=+$P($G(^DIC(42,+ECWARD,44)),U) 208 ..S FAC=$P($G(^DIC(42,+ECWARD,0)),U,11) 209 ..S DSSDEPT=$P($G(^ECX(727.4,ECWARD,0)),U,2) 210 .S ECXWW=WRD_";"_FAC_";"_DSSDEPT,ECDC=+$G(VAIP(17,1)) S:ECDC=0 ECDC="" 211 .S ECXPWP=+VAIP(7) S:ECXPWP=0 ECXPWP="" 212 .S ECXATP=+VAIP(18) S:ECXATP=0 ECXATP="" 213 .S ECXPWPPC=$$PRVCLASS^ECXUTL(ECXPWP,ECADM) 214 .S ECXATPPC=$$PRVCLASS^ECXUTL(ECXATP,ECADM) 215 .;prefix file #200 iens 216 .S:ECXPWP ECXPWP=ECXPROF_ECXPWP S:ECXATP ECXATP=ECXPROF_ECXATP 217 S ECXDOM=$P($G(^ECX(727.831,+ECTS,0)),U,2) 218 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 219 Q ECXINP 220 ; 221 VISN19(ECXDFN,ECXPAYOR,ECXSAI) ;visn 19 sharing agreement data 222 ; input ECXDFN = patient file ien 223 ; output ECXPAYOR, ECXSAI (passed by reference) 224 ; 225 N JJ,ALIAS,INSUR,DIC,DIQ,DA,DR,ECXARY,ECXERR,ECXDA 226 S (ECXPAYOR,ECXSAI)="" 227 D GETS^DIQ(2,ECXDFN,"1*,","I","ECXARY","ECXERR") 228 I $D(ECXERR) Q 229 S JJ=0 F S JJ=$O(ECXARY(2.01,JJ)) Q:JJ="" D I ECXPAYOR]"" Q 230 . S ALIAS=$G(ECXARY(2.01,JJ,.01,"I")) 231 . 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:"") 232 . W !,$G(CNT)+1 233 . W !,"The value of ECXPAYOR is: ",ECXPAYOR 234 ;K ECXARY,ECXERR 235 I ECXPAYOR]"" D GETS^DIQ(2,ECXDFN,".3121*,","I","ECXARY","ECXERR") D 236 . W !,"This is a test" 237 . I $D(ECXERR) Q 238 . S JJ=0,ECXDA=$O(ECXARY(2.312,JJ)) I ECXDA="" Q 239 . S DA=$G(ECXARY(2.312,ECXDA,.01,"I")) I DA="" Q 240 . S INSUR=$$GET1^DIQ(36,DA,".01","I","","ECXERR") 241 . I '$D(ECXERR) S ECXSAI=$E(ECXARY(2.312,ECXDA,.01,"I"),1,11) 242 Q -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXUTL3.m
r613 r623 1 ECXUTL3 ;ALB/GTS - Utilities for DSS Extracts ; 9/28/07 1:38pm 2 ;;3.0;DSS EXTRACTS;**11,24,32,33,35,37,39,42,46,92,105**;Dec 22,1997;Build 70 3 ; 4 OUTPTTM(ECXDFN,ECXDT) ;* Return PC Team from PCMM files or DPT 5 ; Variables - 6 ; ECXDFN - IEN from Patient file (Required) 7 ; ECXDT - Relevant Date for Primary Care Team 8 ; (Defaults to DT) 9 ; 10 ; Returned: ECXTM - 11 ; Pointer to team file (#404.51) 12 ; or, if error or none defined, returns 0 13 ; 14 Q:'$G(ECXDFN) 0 ;** Quit if ECXDFN not defined 15 N ECXTM 16 S:'$D(ECXDT) ECXDT=DT 17 I $T(OUTPTTM^SDUTL3)[",SCDATE" D 18 .S ECXTM=+$$OUTPTTM^SDUTL3(ECXDFN,ECXDT) 19 I $T(OUTPTTM^SDUTL3)'[",SCDATE" D 20 .S ECXTM=+$$OUTPTTM^SDUTL3(ECXDFN) 21 I ECXTM=0 D 22 .S ECXTM=+$P($G(^DPT(+ECXDFN,"PC")),U,2) 23 Q ECXTM 24 ; 25 OUTPTPR(ECXDFN,ECXDT) ;* Return PC Provider from PCMM files or DPT 26 ; Variables - 27 ; ECXDFN - IEN from Patient file (Required) 28 ; ECXDT - Relevant Date for Primary Care Provider 29 ; (Defaults to DT) 30 ; 31 ; Returned: ECXPR - 32 ; Pointer to file #200 33 ; or, if error or none defined, returns a 0 34 ; 35 Q:'$G(ECXDFN) 0 ;** Quit if ECXDFN not defined 36 N ECXPR 37 S:'$D(ECXDT) ECXDT=DT 38 I $T(OUTPTPR^SDUTL3)[",SCDATE" D 39 .S ECXPR=+$$OUTPTPR^SDUTL3(ECXDFN,ECXDT) 40 I $T(OUTPTPR^SDUTL3)'[",SCDATE" D 41 .S ECXPR=+$$OUTPTPR^SDUTL3(ECXDFN) 42 I ECXPR=0 D 43 .S ECXPR=+$G(^DPT(+ECXDFN,"PC")) 44 Q ECXPR 45 ; 46 PAT(ECXDFN,ECXDATE,ECXDATA,ECXPAT) ;Return basic patient data for extract 47 ; Will not return data associated with test patients (SSN begin w 00000) 48 ; Variables - 49 ; Input ECXDFN - Patient internal entry number, DFN file#2; required 50 ; ECXDATE- Date used to get specific data from GETSTAT^DGMSTAPI 51 ; for MST. If no date, defaults to today's date, 52 ; standard FM format, optional 53 ; ECXDATA- Code indicating which data to return, optional. 54 ; If code not specified then returns all. Codes are: 55 ; 1 - DEM^VADPT (demographic data) 56 ; 2 - ADD^VADPT (current address) 57 ; 3 - ELIG^VADPT (eligibility & enrollment location) 58 ; 4 - OPD^VADPT (other patient data) 59 ; 5 - SVC^VADPT & GETSTAT^DGMSTAPI (service & MST inf) 60 ; ECXPAT(- Passed by reference; required 61 ; 62 ; Output: 63 ; ECXPAT 0 error or test patient no data in ECXPAT array 64 ; 1 data returned in ECXPAT array 65 ; ECXPAT( Local array with patient data. 66 ; 67 N SSN,I,ECXCOD,ECXDAT,DFN,VAPA,VADM,VAEL,VAPD,VASV,STR,ECXAR,DIC,DIQ,RCNUM,RCVAL,COLMETH 68 N DA,DR,PELG,MELIG,ZIP,MPI 69 I ECXDFN="" Q 0 70 S SSN=$$GET1^DIQ(2,ECXDFN,.09,"I"),DFN=ECXDFN,ECXPAT=0 71 I $E(SSN,1,3)="000"!(SSN="") K ECXPAT Q 0 ;test patient 72 ;test patient extended checks; mtl extract excluded 73 I $G(ECHEAD)'="MTL",'$$SSN^ECXUTL5(SSN) K ECXPAT Q 0 74 S STR="NAME;SSN;DOB;SEX;RACE;RELIGION;STATE;COUNTY;ZIP;SC%;MEANS;ELIG;" 75 S STR=STR_"EMPLOY;AO STAT;IR STAT;EC STAT;POW STAT;POW LOC;MST STAT;" 76 S STR=STR_"ENROLL LOC;MPI;VIETNAM;POS;MARITAL" 77 ;initialize return array values 78 F I=1:1 S ECXDAT=$P(STR,";",I) Q:ECXDAT="" S ECXPAT(ECXDAT)="" 79 F I=1:1:$L(ECXDATA,";") S ECXDAT=$P(ECXDATA,";",I) I ECXDAT'="" D 80 . S ECXCOD(ECXDAT)="" 81 ; 82 ;- Get ICN if MPI installed 83 S X="MPIF001" X ^%ZOSF("TEST") I $T D 84 .; 85 .;- Get 1st piece (either ICN # or -1 if error) 86 . S MPI=+$$GETICN^MPIF001(DFN) 87 .; 88 .;- If error, set to null 89 . S ECXPAT("MPI")=$S(MPI>0:MPI,1:"") 90 D ;get demographic data 91 . I ECXDATA'="",'$D(ECXCOD(1)) Q 92 . D DEM^VADPT 93 . S ECXPAT("NAME")=$E($P(VADM(1),",")_" ",1,4) 94 . S ECXPAT("SSN")=$P(VADM(2),U),ECXPAT("MARITAL")=$P(VADM(10),U) 95 . S ECXPAT("DOB")=$$ECXDOB^ECXUTL($P(VADM(3),U)) 96 . S ECXPAT("SEX")=$P(VADM(5),U),ECXPAT("RELIGION")=$P(VADM(9),U) 97 . S DIC=10,DR=2,DA=+VADM(8),DIQ="ECXAR",DIQ(0)="I" D EN^DIQ1 98 . S ECXPAT("RACE")=$G(ECXAR(10,DA,DR,"I")),ECXPAT=1 99 . ;add new race and ethnicity fields for FY2003 100 . S (ECXPAT("ETHNIC"),ECXPAT("RACE1"))="" 101 . S X="DGUTL4" X ^%ZOSF("TEST") I $T D 102 .. S COLMETH=$$PTR2CODE^DGUTL4($G(VADM(11,1,1)),3,4) I COLMETH="S" D 103 ... S ECXPAT("ETHNIC")=$$PTR2CODE^DGUTL4(+$G(VADM(11,1)),2,4) 104 .. S (RCVAL,RCNUM)="" 105 .. 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 106 ... S RCVAL=$$PTR2CODE^DGUTL4(+$G(VADM(12,RCNUM)),1,4) 107 ... I RCVAL="C" S ECXPAT("RACE1")=RCVAL Q 108 ... S ECXPAT("RACE1")=ECXPAT("RACE1")_RCVAL 109 D ;get address information 110 . I ECXDATA'="",'$D(ECXCOD(2)) Q 111 . D ADD^VADPT 112 . S DIC=5,DR=2,DA=+VAPA(5),DIQ="ECXAR",DIQ(0)="I" D EN^DIQ1 113 . S ECXPAT("STATE")=$G(ECXAR(5,DA,DR,"I")) 114 . S DIC=5,DA=+VAPA(5),DR=3,DR(5.01)=2,DA(5.01)=+VAPA(7),DIQ="ECXAR" 115 . S DIQ(0)="I" D EN^DIQ1 116 . S ECXPAT("COUNTY")=$G(ECXAR(5.01,DA(5.01),2,"I")) 117 . S ECXPAT("ZIP")=$P(VAPA(11),U,2),ECXPAT=1 118 D ;get eligibility information 119 . I ECXDATA'="",'$D(ECXCOD(3)) Q 120 . D ELIG^VADPT 121 . S PELG=$P(VAEL(1),U),MELIG=$S(PELG="":"",1:$$GET1^DIQ(8,PELG,8,"I")) 122 . S ECXPAT("POS")=$P($G(^DIC(21,+VAEL(2),0)),U,3) 123 . S ECXPAT("SC STAT")=$S(+VAEL(3):"Y",+VAEL(3)=0:"N",1:"") 124 . S ECXPAT("SC%")=$P(VAEL(3),U,2) 125 . S ECXPAT("VET")=$S(VAEL(4):"Y",VAEL(4)=0:"N",1:"") 126 . S ECXPAT("MEANS")=$P(VAEL(9),U),ECXPAT=1 127 . S ECXPAT("ELIG")=$$ELIG(MELIG,ECXPAT("SC%")) 128 . ;get enrollment location 129 . S DIC=2,DR=27.02,DA=ECXDFN,DIQ="ECXAR",DIQ(0)="I" D EN^DIQ1 130 . S ECXDAT=$G(ECXAR(2,ECXDFN,DR,"I")) I ECXDAT K ECXAR D 131 . . S DIC=4,DA=ECXDAT,DR=99,DIQ="ECXAR",DIQ(0)="I" D EN^DIQ1 132 . . S ECXPAT("ENROLL LOC")=ECXAR(4,ECXDAT,DR,"I") 133 . ;get Emergency Response Indicator (FEMA) 134 . S ECXPAT("ERI")=$$GET1^DIQ(2,ECXDFN,.181,"I") 135 D ;get other patient information 136 . I ECXDATA'="",'$D(ECXCOD(4)) Q 137 . D OPD^VADPT 138 . S ECXPAT("EMPLOY")=$P(VAPD(7),U),ECXPAT=1 139 D ;get service information 140 . I ECXDATA'="",'$D(ECXCOD(5)) Q 141 . D SVC^VADPT 142 . S ECXPAT("VIETNAM")=$S(VASV(1):"Y",VASV(2)=0:"N",1:"U") 143 . S ECXPAT("AO STAT")=$S(VASV(2):"Y",VASV(2)=0:"N",1:"U") 144 . S ECXPAT("IR STAT")=$S(VASV(3):"Y",VASV(3)=0:"N",1:"U") 145 . S ECXPAT("EC STAT")=$$GET1^DIQ(2,ECXDFN,.322013,"I") 146 . S ECXPAT("POW STAT")=$S(VASV(4):"Y",VASV(4)=0:"N",1:"U") 147 . S ECXPAT("POW LOC")=$P(VASV(4,3),U),ECXPAT=1 148 . S ECXPAT("PHI")=$S(VASV(9)=1:"Y",VASV(9)=0:"N",1:"") 149 . ;- Agent Orange Location (K=Korean DMZ,V=Vietnam) 150 . S ECXPAT("AOL")=$P($G(VASV(2,5)),U) 151 . ;get patient OEF/OIF status and date of return 152 . D OEFDATA^ECXUTL4 153 . ; 154 . ;get patient current MST status 155 . I ECXDATE'="",ECXDATE'["." S ECXDATE=ECXDATE+.9 156 . S X="DGMSTAPI" X ^%ZOSF("TEST") I $T D 157 . . S ECXDAT=$$GETSTAT^DGMSTAPI(DFN,ECXDATE) 158 . . S ECXPAT("MST STAT")=$S(+ECXDAT>0:$P(ECXDAT,U,2),1:"") 159 I 'ECXPAT K ECXPAT Q 0 160 Q 1 161 ; 162 ELIG(ECXELIG,ECXSVCP) ;Converts veteran eligibility code to NPCD code 163 ; Variables - 164 ; Input ECXELIG - Pointer to MAS ELIGIBILITY CODE file #8.1 165 ; ECXSVCP - Number value rep. service connected percentage. 166 ; 167 ; Output: 168 ; ECXNCPD NPCD Eligibility Code 169 ; 170 N TEXT,IEN,SCPER,FND,NPCD,I,ECXBG,ECXEN,ECXNPCD 171 I ECXELIG="" Q "" 172 F I=1:1 S TEXT=$P($T(ELGTXT+I),";",3,999) Q:TEXT="END" D I $D(NPCD) Q 173 . S IEN=$P(TEXT,";"),SCPER=$P(TEXT,";",2) 174 . I ECXELIG=IEN D 175 . . I SCPER="" S NPCD=$P(TEXT,";",3) Q 176 . . S ECXBG=$S($E(SCPER)="<":0,$E(SCPER)=">":$P(SCPER,">",2)+1,SCPER["-":+SCPER,1:"") 177 . . S ECXEN=$S($E(SCPER)="<":$P(SCPER,"<",2),$E(SCPER)=">":100,SCPER["-":$P(SCPER,"-",2),1:"") 178 . . I ECXSVCP'<ECXBG,ECXSVCP'>ECXEN S NPCD=$P(TEXT,";",3) 179 S ECXNPCD=$G(NPCD) 180 Q ECXNPCD 181 ELGTXT ;Eligibility codes 182 ;;1;>49;10;SC 50-100% 183 ;;2;;20;Aid & Attendance 184 ;;15;;21;Housebound 185 ;;16;;22;Mexican Border War 186 ;;17;;23;WWI 187 ;;18;;24;POW 188 ;;3;40-49;30;SC 40-49% 189 ;;3;30-39;31;SC 30-39% 190 ;;3;20-29;32;SC 20-29% 191 ;;3;10-19;33;SC 10-19% 192 ;;3;<10;34;SC less than 10% 193 ;;4;;40;NSC - VA Pension 194 ;;5;;50;NSC 195 ;;21;;60;Catastrophic Disability 196 ;;12;;101;CHAMPVA 197 ;;13;;102;Collateral of Veteran 198 ;;14;;103;Employee 199 ;;6;;104;Other Federal Agency 200 ;;7;;105;Allied Veteran 201 ;;8;;106;Humanitarian Emergency 202 ;;9;;107;Sharing Agreement 203 ;;10;;108;Reimbursable Insurance 204 ;;19;;109;TRICARE/CHAMPUS 205 ;;22;;25;Purple Heart Recipient 206 ;;END 207 ; 208 CPT(ECXCPT,ECXMOD,ECXQUA) ;Returns a str with CPT code and modifier codes 209 ;Return string is composed of a 5 character CPT code 2 character quantity 210 ;plus up to 5 modifier codes, 2 characters each. 211 ; Variables - 212 ; Input ECXCPT - Pointer value to the CPT file (#81) 213 ; ECXMOD - A string with pointer values to the CPT 214 ; MODIFIER file (#81.3) separated by ";" 215 ; ECXQUA - Number of time this procedure performed 216 ; 217 ; Output: 218 ; CPTMOD - String of up to 17 characters, 5 character CPT 219 ; code 2 character qty plus up to 5 2-character 220 ; code modifiers. 221 ; 222 N CPT,MOD,I,CPTMOD 223 S ECXQUA=$G(ECXQUA,"01"),ECXMOD=$G(ECXMOD) 224 S:$L(ECXQUA)'=2 ECXQUA="0"_ECXQUA 225 S CPT=$$CPT^ICPTCOD(ECXCPT,"") I +CPT=-1 Q "" 226 S CPT=$P(CPT,U,2)_ECXQUA 227 F I=1:1:99 I $P(ECXMOD,";",I)'="" D 228 . S MOD=$$MOD^ICPTMOD($P(ECXMOD,";",I),"I","") 229 . I +MOD>0,$P(MOD,U,2)'="99" S CPT=CPT_$P(MOD,U,2) 230 S CPTMOD=$TR($E(CPT,1,17)," ") 231 Q CPTMOD 232 ; 233 CPTOUT(ECXCPT) ;output transform for CPT code plus modifiers 234 ;input ECXCPT - character string of CPT code plus modifiers (required) 235 ; 236 N J,CPTX,MOD,MODS,MODX,CPTMOD 237 Q:$G(ECXCPT)="" "" 238 S (CPTMOD,MODX)="" 239 S CPTX="("_+$E(ECXCPT,6,7)_") "_$E(ECXCPT,1,5),MODS=$E(ECXCPT,8,17) 240 F J=1:2:9 S MOD=$E(MODS,J,J+1) Q:MOD="" D 241 .I J>1 S MODX=MODX_", "_MOD Q 242 .S MODX=MODX_"-"_MOD 243 S:$L(CPTX)>3 CPTMOD=CPTMOD_CPTX_MODX 244 Q CPTMOD 1 ECXUTL3 ;ALB/GTS - Utilities for DSS Extracts ; 11/2/06 9:07am 2 ;;3.0;DSS EXTRACTS;**11,24,32,33,35,37,39,42,46,92**;Dec 22,1997;Build 30 3 ; 4 OUTPTTM(ECXDFN,ECXDT) ;* Return PC Team from PCMM files or DPT 5 ; Variables - 6 ; ECXDFN - IEN from Patient file (Required) 7 ; ECXDT - Relevant Date for Primary Care Team 8 ; (Defaults to DT) 9 ; 10 ; Returned: ECXTM - 11 ; Pointer to team file (#404.51) 12 ; or, if error or none defined, returns 0 13 ; 14 Q:'$G(ECXDFN) 0 ;** Quit if ECXDFN not defined 15 N ECXTM 16 S:'$D(ECXDT) ECXDT=DT 17 I $T(OUTPTTM^SDUTL3)[",SCDATE" D 18 .S ECXTM=+$$OUTPTTM^SDUTL3(ECXDFN,ECXDT) 19 I $T(OUTPTTM^SDUTL3)'[",SCDATE" D 20 .S ECXTM=+$$OUTPTTM^SDUTL3(ECXDFN) 21 I ECXTM=0 D 22 .S ECXTM=+$P($G(^DPT(+ECXDFN,"PC")),U,2) 23 Q ECXTM 24 ; 25 OUTPTPR(ECXDFN,ECXDT) ;* Return PC Provider from PCMM files or DPT 26 ; Variables - 27 ; ECXDFN - IEN from Patient file (Required) 28 ; ECXDT - Relevant Date for Primary Care Provider 29 ; (Defaults to DT) 30 ; 31 ; Returned: ECXPR - 32 ; Pointer to file #200 33 ; or, if error or none defined, returns a 0 34 ; 35 Q:'$G(ECXDFN) 0 ;** Quit if ECXDFN not defined 36 N ECXPR 37 S:'$D(ECXDT) ECXDT=DT 38 I $T(OUTPTPR^SDUTL3)[",SCDATE" D 39 .S ECXPR=+$$OUTPTPR^SDUTL3(ECXDFN,ECXDT) 40 I $T(OUTPTPR^SDUTL3)'[",SCDATE" D 41 .S ECXPR=+$$OUTPTPR^SDUTL3(ECXDFN) 42 I ECXPR=0 D 43 .S ECXPR=+$G(^DPT(+ECXDFN,"PC")) 44 Q ECXPR 45 ; 46 PAT(ECXDFN,ECXDATE,ECXDATA,ECXPAT) ;Return basic patient data for extract 47 ; Will not return data associated with test patients (SSN begin w 00000) 48 ; Variables - 49 ; Input ECXDFN - Patient internal entry number, DFN file#2; required 50 ; ECXDATE- Date used to get specific data from GETSTAT^DGMSTAPI 51 ; for MST. If no date, defaults to today's date, 52 ; standard FM format, optional 53 ; ECXDATA- Code indicating which data to return, optional. 54 ; If code not specified then returns all. Codes are: 55 ; 1 - DEM^VADPT (demographic data) 56 ; 2 - ADD^VADPT (current address) 57 ; 3 - ELIG^VADPT (eligibility & enrollment location) 58 ; 4 - OPD^VADPT (other patient data) 59 ; 5 - SVC^VADPT & GETSTAT^DGMSTAPI (service & MST inf) 60 ; ECXPAT(- Passed by reference; required 61 ; 62 ; Output: 63 ; ECXPAT 0 error or test patient no data in ECXPAT array 64 ; 1 data returned in ECXPAT array 65 ; ECXPAT( Local array with patient data. 66 ; 67 N SSN,I,ECXCOD,ECXDAT,DFN,VAPA,VADM,VAEL,VAPD,VASV,STR,ECXAR,DIC,DIQ,RCNUM,RCVAL,COLMETH 68 N DA,DR,PELG,MELIG,ZIP,MPI 69 I ECXDFN="" Q 0 70 S SSN=$$GET1^DIQ(2,ECXDFN,.09,"I"),DFN=ECXDFN,ECXPAT=0 71 I $E(SSN,1,5)="00000"!(SSN="") K ECXPAT Q 0 ;test patient 72 S STR="NAME;SSN;DOB;SEX;RACE;RELIGION;STATE;COUNTY;ZIP;SC%;MEANS;ELIG;" 73 S STR=STR_"EMPLOY;AO STAT;IR STAT;EC STAT;POW STAT;POW LOC;MST STAT;" 74 S STR=STR_"ENROLL LOC;MPI;VIETNAM;POS;MARITAL" 75 ;initialize return array values 76 F I=1:1 S ECXDAT=$P(STR,";",I) Q:ECXDAT="" S ECXPAT(ECXDAT)="" 77 F I=1:1:$L(ECXDATA,";") S ECXDAT=$P(ECXDATA,";",I) I ECXDAT'="" D 78 . S ECXCOD(ECXDAT)="" 79 ; 80 ;- Get ICN if MPI installed 81 S X="MPIF001" X ^%ZOSF("TEST") I $T D 82 .; 83 .;- Get 1st piece (either ICN # or -1 if error) 84 . S MPI=+$$GETICN^MPIF001(DFN) 85 .; 86 .;- If error, set to null 87 . S ECXPAT("MPI")=$S(MPI>0:MPI,1:"") 88 D ;get demographic data 89 . I ECXDATA'="",'$D(ECXCOD(1)) Q 90 . D DEM^VADPT 91 . S ECXPAT("NAME")=$E($P(VADM(1),",")_" ",1,4) 92 . S ECXPAT("SSN")=$P(VADM(2),U),ECXPAT("MARITAL")=$P(VADM(10),U) 93 . S ECXPAT("DOB")=$$ECXDOB^ECXUTL($P(VADM(3),U)) 94 . S ECXPAT("SEX")=$P(VADM(5),U),ECXPAT("RELIGION")=$P(VADM(9),U) 95 . S DIC=10,DR=2,DA=+VADM(8),DIQ="ECXAR",DIQ(0)="I" D EN^DIQ1 96 . S ECXPAT("RACE")=$G(ECXAR(10,DA,DR,"I")),ECXPAT=1 97 . ;add new race and ethnicity fields for FY2003 98 . S (ECXPAT("ETHNIC"),ECXPAT("RACE1"))="" 99 . S X="DGUTL4" X ^%ZOSF("TEST") I $T D 100 .. S COLMETH=$$PTR2CODE^DGUTL4($G(VADM(11,1,1)),3,4) I COLMETH="S" D 101 ... S ECXPAT("ETHNIC")=$$PTR2CODE^DGUTL4(+$G(VADM(11,1)),2,4) 102 .. S (RCVAL,RCNUM)="" 103 .. 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 104 ... S RCVAL=$$PTR2CODE^DGUTL4(+$G(VADM(12,RCNUM)),1,4) 105 ... I RCVAL="C" S ECXPAT("RACE1")=RCVAL Q 106 ... S ECXPAT("RACE1")=ECXPAT("RACE1")_RCVAL 107 D ;get address information 108 . I ECXDATA'="",'$D(ECXCOD(2)) Q 109 . D ADD^VADPT 110 . S DIC=5,DR=2,DA=+VAPA(5),DIQ="ECXAR",DIQ(0)="I" D EN^DIQ1 111 . S ECXPAT("STATE")=$G(ECXAR(5,DA,DR,"I")) 112 . S DIC=5,DA=+VAPA(5),DR=3,DR(5.01)=2,DA(5.01)=+VAPA(7),DIQ="ECXAR" 113 . S DIQ(0)="I" D EN^DIQ1 114 . S ECXPAT("COUNTY")=$G(ECXAR(5.01,DA(5.01),2,"I")) 115 . S ECXPAT("ZIP")=$P(VAPA(11),U,2),ECXPAT=1 116 D ;get eligibility information 117 . I ECXDATA'="",'$D(ECXCOD(3)) Q 118 . D ELIG^VADPT 119 . S PELG=$P(VAEL(1),U),MELIG=$S(PELG="":"",1:$$GET1^DIQ(8,PELG,8,"I")) 120 . S ECXPAT("POS")=$P($G(^DIC(21,+VAEL(2),0)),U,3) 121 . S ECXPAT("SC STAT")=$S(+VAEL(3):"Y",+VAEL(3)=0:"N",1:"") 122 . S ECXPAT("SC%")=$P(VAEL(3),U,2) 123 . S ECXPAT("VET")=$S(VAEL(4):"Y",VAEL(4)=0:"N",1:"") 124 . S ECXPAT("MEANS")=$P(VAEL(9),U),ECXPAT=1 125 . S ECXPAT("ELIG")=$$ELIG(MELIG,ECXPAT("SC%")) 126 . ;get enrollment location 127 . S DIC=2,DR=27.02,DA=ECXDFN,DIQ="ECXAR",DIQ(0)="I" D EN^DIQ1 128 . S ECXDAT=$G(ECXAR(2,ECXDFN,DR,"I")) I ECXDAT K ECXAR D 129 . . S DIC=4,DA=ECXDAT,DR=99,DIQ="ECXAR",DIQ(0)="I" D EN^DIQ1 130 . . S ECXPAT("ENROLL LOC")=ECXAR(4,ECXDAT,DR,"I") 131 . ;get Emergency Response Indicator (FEMA) 132 . S ECXPAT("ERI")=$$GET1^DIQ(2,ECXDFN,.181,"I") 133 D ;get other patient information 134 . I ECXDATA'="",'$D(ECXCOD(4)) Q 135 . D OPD^VADPT 136 . S ECXPAT("EMPLOY")=$P(VAPD(7),U),ECXPAT=1 137 D ;get service information 138 . I ECXDATA'="",'$D(ECXCOD(5)) Q 139 . D SVC^VADPT 140 . S ECXPAT("VIETNAM")=$S(VASV(1):"Y",VASV(2)=0:"N",1:"U") 141 . S ECXPAT("AO STAT")=$S(VASV(2):"Y",VASV(2)=0:"N",1:"U") 142 . S ECXPAT("IR STAT")=$S(VASV(3):"Y",VASV(3)=0:"N",1:"U") 143 . S ECXPAT("EC STAT")=$$GET1^DIQ(2,ECXDFN,.322013,"I") 144 . S ECXPAT("POW STAT")=$S(VASV(4):"Y",VASV(4)=0:"N",1:"U") 145 . S ECXPAT("POW LOC")=$P(VASV(4,3),U),ECXPAT=1 146 . S ECXPAT("PHI")=$S(VASV(9)=1:"Y",VASV(9)=0:"N",1:"") 147 . ;- Agent Orange Location (K=Korean DMZ,V=Vietnam) 148 . S ECXPAT("AOL")=$P($G(VASV(2,5)),U) 149 . ;get patient current MST status 150 . I ECXDATE'="",ECXDATE'["." S ECXDATE=ECXDATE+.9 151 . S X="DGMSTAPI" X ^%ZOSF("TEST") I $T D 152 . . S ECXDAT=$$GETSTAT^DGMSTAPI(DFN,ECXDATE) 153 . . S ECXPAT("MST STAT")=$S(+ECXDAT>0:$P(ECXDAT,U,2),1:"") 154 I 'ECXPAT K ECXPAT Q 0 155 Q 1 156 ; 157 ELIG(ECXELIG,ECXSVCP) ;Converts veteran eligibility code to NPCD code 158 ; Variables - 159 ; Input ECXELIG - Pointer to MAS ELIGIBILITY CODE file #8.1 160 ; ECXSVCP - Number value rep. service connected percentage. 161 ; 162 ; Output: 163 ; ECXNCPD NPCD Eligibility Code 164 ; 165 N TEXT,IEN,SCPER,FND,NPCD,I,ECXBG,ECXEN,ECXNPCD 166 I ECXELIG="" Q "" 167 F I=1:1 S TEXT=$P($T(ELGTXT+I),";",3,999) Q:TEXT="END" D I $D(NPCD) Q 168 . S IEN=$P(TEXT,";"),SCPER=$P(TEXT,";",2) 169 . I ECXELIG=IEN D 170 . . I SCPER="" S NPCD=$P(TEXT,";",3) Q 171 . . S ECXBG=$S($E(SCPER)="<":0,$E(SCPER)=">":$P(SCPER,">",2)+1,SCPER["-":+SCPER,1:"") 172 . . S ECXEN=$S($E(SCPER)="<":$P(SCPER,"<",2),$E(SCPER)=">":100,SCPER["-":$P(SCPER,"-",2),1:"") 173 . . I ECXSVCP'<ECXBG,ECXSVCP'>ECXEN S NPCD=$P(TEXT,";",3) 174 S ECXNPCD=$G(NPCD) 175 Q ECXNPCD 176 ELGTXT ;Eligibility codes 177 ;;1;>49;10;SC 50-100% 178 ;;2;;20;Aid & Attendance 179 ;;15;;21;Housebound 180 ;;16;;22;Mexican Border War 181 ;;17;;23;WWI 182 ;;18;;24;POW 183 ;;3;40-49;30;SC 40-49% 184 ;;3;30-39;31;SC 30-39% 185 ;;3;20-29;32;SC 20-29% 186 ;;3;10-19;33;SC 10-19% 187 ;;3;<10;34;SC less than 10% 188 ;;4;;40;NSC - VA Pension 189 ;;5;;50;NSC 190 ;;21;;60;Catastrophic Disability 191 ;;12;;101;CHAMPVA 192 ;;13;;102;Collateral of Veteran 193 ;;14;;103;Employee 194 ;;6;;104;Other Federal Agency 195 ;;7;;105;Allied Veteran 196 ;;8;;106;Humanitarian Emergency 197 ;;9;;107;Sharing Agreement 198 ;;10;;108;Reimbursable Insurance 199 ;;19;;109;TRICARE/CHAMPUS 200 ;;22;;25;Purple Heart Recipient 201 ;;END 202 ; 203 CPT(ECXCPT,ECXMOD,ECXQUA) ;Returns a str with CPT code and modifier codes 204 ;Return string is composed of a 5 character CPT code 2 character quantity 205 ;plus up to 5 modifier codes, 2 characters each. 206 ; Variables - 207 ; Input ECXCPT - Pointer value to the CPT file (#81) 208 ; ECXMOD - A string with pointer values to the CPT 209 ; MODIFIER file (#81.3) separated by ";" 210 ; ECXQUA - Number of time this procedure performed 211 ; 212 ; Output: 213 ; CPTMOD - String of up to 17 characters, 5 character CPT 214 ; code 2 character qty plus up to 5 2-character 215 ; code modifiers. 216 ; 217 N CPT,MOD,I,CPTMOD 218 S ECXQUA=$G(ECXQUA,"01"),ECXMOD=$G(ECXMOD) 219 S:$L(ECXQUA)'=2 ECXQUA="0"_ECXQUA 220 S CPT=$$CPT^ICPTCOD(ECXCPT,"") I +CPT=-1 Q "" 221 S CPT=$P(CPT,U,2)_ECXQUA 222 F I=1:1:99 I $P(ECXMOD,";",I)'="" D 223 . S MOD=$$MOD^ICPTMOD($P(ECXMOD,";",I),"I","") 224 . I +MOD>0,$P(MOD,U,2)'="99" S CPT=CPT_$P(MOD,U,2) 225 S CPTMOD=$TR($E(CPT,1,17)," ") 226 Q CPTMOD 227 ; 228 CPTOUT(ECXCPT) ;output transform for CPT code plus modifiers 229 ;input ECXCPT - character string of CPT code plus modifiers (required) 230 ; 231 N J,CPTX,MOD,MODS,MODX,CPTMOD 232 Q:$G(ECXCPT)="" "" 233 S (CPTMOD,MODX)="" 234 S CPTX="("_+$E(ECXCPT,6,7)_") "_$E(ECXCPT,1,5),MODS=$E(ECXCPT,8,17) 235 F J=1:2:9 S MOD=$E(MODS,J,J+1) Q:MOD="" D 236 .I J>1 S MODX=MODX_", "_MOD Q 237 .S MODX=MODX_"-"_MOD 238 S:$L(CPTX)>3 CPTMOD=CPTMOD_CPTX_MODX 239 Q CPTMOD -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXUTL4.m
r613 r623 1 ECXUTL4 ;ALB/ESD - Utilities for DSS Extracts ; 11/26/07 10:58am 2 ;;3.0;DSS EXTRACTS;**39,41,46,49,78,92,105**;Dec 22,1997;Build 70 3 ; 4 OBSPAT(ECXIO,ECXTS,DSSID) ; 5 ; Get observation patient indicator from DSS TREATING SPECIALTY 6 ; TRANSLATION file (#727.831) or DSS Identifier 7 ; 8 ; Input: 9 ; ECXIO - Inpatient/Outpatient indicator 10 ; ECXTS - Treating specialty (from file #42.4) 11 ; DSSID - DSS Identifier 12 ; 13 ;Output: 14 ; ECXOBS - Observation patient indicator (YES/NO) 15 ; 16 ;- Check input vars 17 S ECXIO=$G(ECXIO),ECXTS=+$G(ECXTS),DSSID=+$G(DSSID) 18 S ECXOBS="" 19 D 20 .;- Look up obs patient indicator if treating spec is in file #727.831 21 . I $G(^ECX(727.831,ECXTS,0)) S ECXOBS=$P($G(^ECX(727.831,ECXTS,0)),"^",4) 22 . I ECXOBS'="" S ECXOBS=$S(ECXOBS="Y":"YES",1:"NO") Q 23 .; 24 .;- If outpatient and TS not in file, AND Feeder Key (CLI) or DSS ID 25 .;- (MTL,IVP,ECQ,QSR,NOS,SUR) is 290-296, Observation Patient Ind=YES 26 . I ECXIO="O",ECXOBS="",DSSID D 27 .. I $E(DSSID,1,3)>289&($E(DSSID,1,3)<297) S ECXOBS="YES" 28 .. E S ECXOBS="NO" 29 Q $S(ECXOBS'="":ECXOBS,1:"NO") 30 ; 31 INOUTP(ECXTS) ; 32 ; Get inpatient/outpatient indicator from DSS TREATING SPECIALTY 33 ; TRANSLATION file (#727.831) 34 ; 35 ; Input: 36 ; ECXTS - Treating specialty 37 ; 38 ; Output: 39 ; Inpatient/Outpatient indicator (I/O) 40 ; 41 S ECXTS=+$G(ECXTS) 42 S ECXIO="" 43 ; 44 ;- Look up inpat/outpat indicator if treating spec is in file 45 I $G(^ECX(727.831,ECXTS,0)) S ECXIO=$P($G(^ECX(727.831,ECXTS,0)),"^",5) 46 Q $S(ECXIO'="":ECXIO,1:"I") 47 ; 48 ENCNUM(ECXIO,ECXSSN,ECXADT,ECXVDT,ECXTRT,ECXOBS,ECXEXT,ECXSTP,ECXSTP2) ; 49 ; Get encounter number 50 ; 51 ; Input: 52 ; ECXIO - Inpat/Outpat indicator = I or O 53 ; ECXSSN - Patient SSN 54 ; ECXADT - Admit Date 55 ; ECXVDT - Visit Date 56 ; ECXTRT - Treating Spec 57 ; ECXOBS - Observation Pat Indicator 58 ; ECXEXT - Extract 59 ; ECXSTP - Stop Code (or stop code related) variable 60 ; ECXSTP2 - Stop Code (or stop code related) addtl variable 61 ; (used for SUR and ECS) 62 ; 63 ;Output: 64 ; Encounter Number 65 ; 66 N ENCNUM,ECXDATE,ECXSTCD 67 S (ENCNUM,ECXSTCD)="" 68 ; 69 ;- Check input vars 70 S ECXEXT=$G(ECXEXT),ECXIO=$G(ECXIO),ECXOBS=$G(ECXOBS),ECXTRT=+$G(ECXTRT) 71 S ECXSTP=+$G(ECXSTP),ECXSTP2=+$G(ECXSTP2) 72 S ECXADT=+$G(ECXADT),ECXVDT=+$G(ECXVDT) 73 ; 74 ;- Don't use pseudo-SSN in encounter number 75 S ECXSSN=$E($G(ECXSSN),1,9) 76 ; 77 D 78 . ;- Inpatient 79 . I ECXIO="I",ECXADT,ECXSSN'="" D Q 80 .. S ECXDATE=$$ADMITDT(ECXADT) 81 .. I ECXDATE'="" S ENCNUM=ECXSSN_ECXDATE_"I" 82 . ; 83 . ;- Outpatient branch 84 . I ECXIO="O" D 85 .. ;- Observation patient (outpatient) 86 .. I ECXOBS="YES",ECXSSN'="" D Q 87 ... ; 88 ... S ECXDATE=$S(ECXADT:$$JULDT(ECXADT),1:$$JULDT(ECXVDT)) 89 ... S ECXSTCD=$S(+$P($G(^ECX(727.831,ECXTRT,0)),"^",6):+$P($G(^ECX(727.831,ECXTRT,0)),"^",6),1:+$E(ECXSTP,1,3)) 90 ... Q:ECXDATE=""!(ECXSTCD="") 91 ... S ENCNUM=ECXSSN_ECXDATE_ECXSTCD 92 .. ; 93 .. ;- Outpatient (no observation pat) 94 .. I ECXOBS="NO",ECXVDT,ECXSSN'="" D Q 95 ... ; 96 ... ;- ADM, MOV, TRT have no outpat encounter number 97 ... I ECXEXT="ADM"!(ECXEXT="MOV")!(ECXEXT="TRT") Q 98 ... ; 99 ... ;- Use 1st 3 chars of DSS ID for NOS and ECQ (feeder key for CLI) 100 ... ;- Use observation stop code for IVP 101 ... I ECXEXT="CLI"!(ECXEXT="NOS")!(ECXEXT="ECQ")!(ECXEXT="IVP") S ECXSTCD=+$E(ECXSTP,1,3) Q:'ECXSTCD 102 ... ; 103 ... ;- Use cost center to obtain stop code for ECS 104 ... I ECXEXT="ECS" D Q:'ECXSTCD 105 .... S ECXSTCD=$$ECSCOST(ECXSTP2) 106 ....; 107 ....;- If no cost center, use 1st 3 chars of DSS ID 108 .... I ECXSTCD="" S ECXSTCD=+$E(ECXSTP,1,3) 109 ... ; 110 ... ;- These extracts have predetermined stop code values 111 ... I ECXEXT="DEN" S ECXSTCD=180 112 ... I ECXEXT="PRE"!(ECXEXT="UDP") S ECXSTCD=160 113 ... I ECXEXT="LAB"!(ECXEXT="LAR")!(ECXEXT="LBB") S ECXSTCD=108 114 ... I ECXEXT="MTL" S ECXSTCD=538 115 ... I ECXEXT="NUR" S ECXSTCD=950 116 ... I ECXEXT="PRO" S ECXSTCD=423 117 ... I ECXEXT="NUT" S ECXSTCD="NUT" 118 ... ; 119 ... ;- If Imaging Type fld=2, use 109 otherwise use 105 120 ... I ECXEXT="RAD" S ECXSTCD=$S(ECXSTP=2:109,1:105) 121 ... ; 122 ... ;- Use DSS STOP CODE fld if populated or if SURG SPEC fld=59 use 430 123 ... ;- otherwise if null use 429 124 ... I ECXEXT="SUR" S ECXSTCD=$S(ECXSTP:ECXSTP,ECXSTP2=59:430,1:429) 125 ... ; 126 ... ;- Get Julian Date 127 ... S ECXDATE=$$JULDT(ECXVDT) 128 ... I ECXDATE'="" S ENCNUM=ECXSSN_ECXDATE_ECXSTCD 129 Q ENCNUM 130 ; 131 ADMITDT(ECXINDT) ; Returns date in YYMMDD format 132 ; 133 ; Input: 134 ; ECXINDT - Date (can also include time) in internal FM format 135 ; 136 ;Output: 137 ; Date in YYMMDD form 138 ; 139 N ECXDT 140 S ECXDT="" 141 S ECXINDT=+$G(ECXINDT) 142 ; 143 ;- If no input or full FM date not passed in, quit 144 I 'ECXINDT!($L(ECXINDT)<7) G ADMTDTQ 145 ; 146 ;- Date in YYMMDD form 147 S ECXDT=$TR($$FMTE^XLFDT(ECXINDT,"4DF")," /","0") 148 ADMTDTQ Q ECXDT 149 ; 150 ; 151 JULDT(ECXINDT) ; Returns Julian Date in MMDDD format 152 ; 153 ; Input: 154 ; ECINDT - Date (can also include time) in internal FM format 155 ; 156 ;Output: 157 ; Julian date in MM_DDD form 158 ; 159 N ECXDDD,ECXDT,ECXJUL,ECXMM 160 S (ECXDDD,ECXMM)="" 161 ; 162 ;- If no input or full FM date not passed in, quit 163 S ECXINDT=+$G(ECXINDT) 164 I 'ECXINDT!($L(ECXINDT)<7) G JULDTQ 165 ; 166 ;- Extract date portion 167 S ECXDT=$E(ECXINDT,1,7) 168 ; 169 ;- Get month (MM) 170 S ECXMM=$E(ECXINDT,2,3) 171 ; 172 ;- Number of day within year (DDD) 173 S ECXDDD=$$RJ^XLFSTR($$FMDIFF^XLFDT(ECXDT,$E(ECXDT,1,3)_"0101",1)+1,3,"0") 174 JULDTQ Q ECXMM_ECXDDD 175 ; 176 CNHSTAT(ECXDFN) ; Get CNH (Contract Nursing Home) status 177 ; 178 ; Input: 179 ; ECXDFN - Patient DFN 180 ; 181 ;Output: 182 ; CNH status (YES/NO) 183 ; 184 N ECXCNH 185 S ECXDFN=+$G(ECXDFN) 186 S ECXCNH=$P($G(^DPT(ECXDFN,"NHC")),U) 187 Q $S(ECXCNH="Y":"YES",ECXCNH="N":"NO",1:"") 188 ; 189 CANC(ECXNOR,ECXTMOR) ; Get Surgery Cancelled/Aborted Status 190 ; 191 ; Function called after determining CANCEL DATE in SURGERY record exists 192 ; 193 ; Input: 194 ; ECXNOR - Non-OR DSS ID 195 ; ECXTMOR - Time Pat in OR 196 ; 197 ;Output: 198 ; Cancelled/aborted status (C/A) 199 ; 200 N ECXCANC 201 S ECXCANC="" 202 S ECXNOR=$G(ECXNOR) 203 ; 204 ;- If Non-OR DSS ID or Time Pat in OR, ECXCANC = "A" else = "C" 205 D 206 . I ECXNOR'=""&(ECXNOR'="UNKNOWN") S ECXCANC="A" Q 207 . I +$G(ECXTMOR) S ECXCANC="A" Q 208 . S ECXCANC="C" 209 Q ECXCANC 210 ; 211 ECSCOST(ECXCOST) ;Get ECS extract stop code based on cost center 212 ; 213 ; 214 ; Input: 215 ; ECXCOST - ECS extract cost center 216 ; 217 ;Output: 218 ; ECS extract stop code 219 ; 220 N ECXFND,ECXSTOP,I 221 S ECXFND=0 222 S ECXSTOP="" 223 S ECXCOST=+$G(ECXCOST) 224 D 225 . I 'ECXCOST Q 226 . F I=1:1 Q:ECXFND!($P($T(COST+I),";;",2)="END") D 227 .. I ECXCOST=$P($T(COST+I),";;",2) S ECXSTOP=$P($T(COST+I),";;",3),ECXFND=1 228 Q ECXSTOP 229 ; 230 COST ;- ECS Cost Center and stop code 231 ;;833100;;652 232 ;;833200;;653 233 ;;833300;;681 234 ;;834100;;651 235 ;;834200;;650 236 ;;834300;;681 237 ;;834400;;654 238 ;;834500;;681 239 ;;834600;;681 240 ;;834700;;681 241 ;;834800;;681 242 ;;834900;;681 243 ;;836100;;654 244 ;;836200;;654 245 ;;END 246 ; 247 HNCI(ECXDFN) ; Get head & neck cancer indicator 248 ; 249 ; Input: 250 ; ECXDFN - Patient DFN 251 ; 252 ;Output: 253 ; Head/Neck CA DX (Y/N) 254 ; 255 N ECXHNCI,DGNT 256 S ECXHNCI="" 257 S ECXDFN=+$G(ECXDFN) I ECXDFN D 258 .I $$GETCUR^DGNTAPI(ECXDFN,"DGNT") S ECXHNCI=$P(DGNT("HNC"),U) 259 Q ECXHNCI 260 ; 261 TSMAP(ECXTS) ;Determines DSS Identifier for the following observation 262 ; treating specialty 263 ; Input: 264 ; ECXTS - Observation Treating Specialty 265 ; 266 ; Output: 267 ; DSS Identifier (Stop Code) 268 ; 269 N TS,SC,I 270 S TS="^18^23^24^36^41^65^94^",SC="^293^295^290^294^296^291^292^" 271 F I=1:1:$L(TS) Q:$P(TS,"^",I)=ECXTS 272 Q $P(SC,"^",I)_"000" 273 OEFDATA ; 274 ;get patient OEF/OIF status and date of return 275 S (ECXOEF,ECXOEFDT)="" 276 I $G(VASV(11))>0 S ECXOEF=ECXOEF_"OIF" 277 I $G(VASV(12))>0 S ECXOEF=ECXOEF_"OEF" 278 I $G(VASV(13))>0 S ECXOEF=ECXOEF_"UNK" 279 I ECXOEF'="" D 280 . S ECXOEFDT="" 281 . I $G(VASV(11))>0 S ECXOEFDT=$P($G(VASV(11,$G(VASV(11)),3)),"^") 282 . I $G(VASV(12))>0,$P($G(VASV(12,$G(VASV(12)),3)),"^")>ECXOEFDT S ECXOEFDT=$P($G(VASV(12,$G(VASV(12)),3)),"^") 283 . I $G(VASV(13))>0,$P($G(VASV(13,$G(VASV(13)),3)),"^")>ECXOEFDT S ECXOEFDT=$P($G(VASV(13,$G(VASV(13)),3)),"^") 284 . I ECXOEFDT>0 S ECXOEFDT=17000000+ECXOEFDT 285 ; 286 S ECXPAT("ECXOEF")=ECXOEF 287 S ECXPAT("ECXOEFDT")=ECXOEFDT 288 Q 1 ECXUTL4 ;ALB/ESD - Utilities for DSS Extracts ; 11/2/06 9:08am 2 ;;3.0;DSS EXTRACTS;**39,41,46,49,78,92**;Dec 22,1997;Build 30 3 ; 4 OBSPAT(ECXIO,ECXTS,DSSID) ; 5 ; Get observation patient indicator from DSS TREATING SPECIALTY 6 ; TRANSLATION file (#727.831) or DSS Identifier 7 ; 8 ; Input: 9 ; ECXIO - Inpatient/Outpatient indicator 10 ; ECXTS - Treating specialty (from file #42.4) 11 ; DSSID - DSS Identifier 12 ; 13 ;Output: 14 ; ECXOBS - Observation patient indicator (YES/NO) 15 ; 16 ;- Check input vars 17 S ECXIO=$G(ECXIO),ECXTS=+$G(ECXTS),DSSID=+$G(DSSID) 18 S ECXOBS="" 19 D 20 .;- Look up obs patient indicator if treating spec is in file #727.831 21 . I $G(^ECX(727.831,ECXTS,0)) S ECXOBS=$P($G(^ECX(727.831,ECXTS,0)),"^",4) 22 . I ECXOBS'="" S ECXOBS=$S(ECXOBS="Y":"YES",1:"NO") Q 23 .; 24 .;- If outpatient and TS not in file, AND Feeder Key (CLI) or DSS ID 25 .;- (MTL,IVP,ECQ,QSR,NOS,SUR) is 290-296, Observation Patient Ind=YES 26 . I ECXIO="O",ECXOBS="",DSSID D 27 .. I $E(DSSID,1,3)>289&($E(DSSID,1,3)<297) S ECXOBS="YES" 28 .. E S ECXOBS="NO" 29 Q $S(ECXOBS'="":ECXOBS,1:"NO") 30 ; 31 INOUTP(ECXTS) ; 32 ; Get inpatient/outpatient indicator from DSS TREATING SPECIALTY 33 ; TRANSLATION file (#727.831) 34 ; 35 ; Input: 36 ; ECXTS - Treating specialty 37 ; 38 ; Output: 39 ; Inpatient/Outpatient indicator (I/O) 40 ; 41 S ECXTS=+$G(ECXTS) 42 S ECXIO="" 43 ; 44 ;- Look up inpat/outpat indicator if treating spec is in file 45 I $G(^ECX(727.831,ECXTS,0)) S ECXIO=$P($G(^ECX(727.831,ECXTS,0)),"^",5) 46 Q $S(ECXIO'="":ECXIO,1:"I") 47 ; 48 ENCNUM(ECXIO,ECXSSN,ECXADT,ECXVDT,ECXTRT,ECXOBS,ECXEXT,ECXSTP,ECXSTP2) ; 49 ; Get encounter number 50 ; 51 ; Input: 52 ; ECXIO - Inpat/Outpat indicator = I or O 53 ; ECXSSN - Patient SSN 54 ; ECXADT - Admit Date 55 ; ECXVDT - Visit Date 56 ; ECXTRT - Treating Spec 57 ; ECXOBS - Observation Pat Indicator 58 ; ECXEXT - Extract 59 ; ECXSTP - Stop Code (or stop code related) variable 60 ; ECXSTP2 - Stop Code (or stop code related) addtl variable 61 ; (used for SUR and ECS) 62 ; 63 ;Output: 64 ; Encounter Number 65 ; 66 N ENCNUM,ECXDATE,ECXSTCD 67 S (ENCNUM,ECXSTCD)="" 68 ; 69 ;- Check input vars 70 S ECXEXT=$G(ECXEXT),ECXIO=$G(ECXIO),ECXOBS=$G(ECXOBS),ECXTRT=+$G(ECXTRT) 71 S ECXSTP=+$G(ECXSTP),ECXSTP2=+$G(ECXSTP2) 72 S ECXADT=+$G(ECXADT),ECXVDT=+$G(ECXVDT) 73 ; 74 ;- Don't use pseudo-SSN in encounter number 75 S ECXSSN=$E($G(ECXSSN),1,9) 76 ; 77 D 78 . ;- Inpatient 79 . I ECXIO="I",ECXADT,ECXSSN'="" D Q 80 .. S ECXDATE=$$ADMITDT(ECXADT) 81 .. I ECXDATE'="" S ENCNUM=ECXSSN_ECXDATE_"I" 82 . ; 83 . ;- Outpatient branch 84 . I ECXIO="O" D 85 .. ;- Observation patient (outpatient) 86 .. I ECXOBS="YES",ECXSSN'="" D Q 87 ... ; 88 ... S ECXDATE=$S(ECXADT:$$JULDT(ECXADT),1:$$JULDT(ECXVDT)) 89 ... S ECXSTCD=$S(+$P($G(^ECX(727.831,ECXTRT,0)),"^",6):+$P($G(^ECX(727.831,ECXTRT,0)),"^",6),1:+$E(ECXSTP,1,3)) 90 ... Q:ECXDATE=""!(ECXSTCD="") 91 ... S ENCNUM=ECXSSN_ECXDATE_ECXSTCD 92 .. ; 93 .. ;- Outpatient (no observation pat) 94 .. I ECXOBS="NO",ECXVDT,ECXSSN'="" D Q 95 ... ; 96 ... ;- ADM, MOV, TRT have no outpat encounter number 97 ... I ECXEXT="ADM"!(ECXEXT="MOV")!(ECXEXT="TRT") Q 98 ... ; 99 ... ;- Use 1st 3 chars of DSS ID for NOS and ECQ (feeder key for CLI) 100 ... ;- Use observation stop code for IVP 101 ... I ECXEXT="CLI"!(ECXEXT="NOS")!(ECXEXT="ECQ")!(ECXEXT="IVP") S ECXSTCD=+$E(ECXSTP,1,3) Q:'ECXSTCD 102 ... ; 103 ... ;- Use cost center to obtain stop code for ECS 104 ... I ECXEXT="ECS" D Q:'ECXSTCD 105 .... S ECXSTCD=$$ECSCOST(ECXSTP2) 106 ....; 107 ....;- If no cost center, use 1st 3 chars of DSS ID 108 .... I ECXSTCD="" S ECXSTCD=+$E(ECXSTP,1,3) 109 ... ; 110 ... ;- These extracts have predetermined stop code values 111 ... I ECXEXT="DEN" S ECXSTCD=180 112 ... I ECXEXT="PRE"!(ECXEXT="UDP") S ECXSTCD=160 113 ... I ECXEXT="LAB"!(ECXEXT="LAR")!(ECXEXT="LBB") S ECXSTCD=108 114 ... I ECXEXT="MTL" S ECXSTCD=538 115 ... I ECXEXT="NUR" S ECXSTCD=950 116 ... I ECXEXT="PRO" S ECXSTCD=423 117 ... I ECXEXT="NUT" S ECXSTCD="NUT" 118 ... ; 119 ... ;- If Imaging Type fld=2, use 109 otherwise use 105 120 ... I ECXEXT="RAD" S ECXSTCD=$S(ECXSTP=2:109,1:105) 121 ... ; 122 ... ;- Use DSS STOP CODE fld if populated or if SURG SPEC fld=59 use 430 123 ... ;- otherwise if null use 429 124 ... I ECXEXT="SUR" S ECXSTCD=$S(ECXSTP:ECXSTP,ECXSTP2=59:430,1:429) 125 ... ; 126 ... ;- Get Julian Date 127 ... S ECXDATE=$$JULDT(ECXVDT) 128 ... I ECXDATE'="" S ENCNUM=ECXSSN_ECXDATE_ECXSTCD 129 Q ENCNUM 130 ; 131 ADMITDT(ECXINDT) ; Returns date in YYMMDD format 132 ; 133 ; Input: 134 ; ECXINDT - Date (can also include time) in internal FM format 135 ; 136 ;Output: 137 ; Date in YYMMDD form 138 ; 139 N ECXDT 140 S ECXDT="" 141 S ECXINDT=+$G(ECXINDT) 142 ; 143 ;- If no input or full FM date not passed in, quit 144 I 'ECXINDT!($L(ECXINDT)<7) G ADMTDTQ 145 ; 146 ;- Date in YYMMDD form 147 S ECXDT=$TR($$FMTE^XLFDT(ECXINDT,"4DF")," /","0") 148 ADMTDTQ Q ECXDT 149 ; 150 ; 151 JULDT(ECXINDT) ; Returns Julian Date in MMDDD format 152 ; 153 ; Input: 154 ; ECINDT - Date (can also include time) in internal FM format 155 ; 156 ;Output: 157 ; Julian date in MM_DDD form 158 ; 159 N ECXDDD,ECXDT,ECXJUL,ECXMM 160 S (ECXDDD,ECXMM)="" 161 ; 162 ;- If no input or full FM date not passed in, quit 163 S ECXINDT=+$G(ECXINDT) 164 I 'ECXINDT!($L(ECXINDT)<7) G JULDTQ 165 ; 166 ;- Extract date portion 167 S ECXDT=$E(ECXINDT,1,7) 168 ; 169 ;- Get month (MM) 170 S ECXMM=$E(ECXINDT,2,3) 171 ; 172 ;- Number of day within year (DDD) 173 S ECXDDD=$$RJ^XLFSTR($$FMDIFF^XLFDT(ECXDT,$E(ECXDT,1,3)_"0101",1)+1,3,"0") 174 JULDTQ Q ECXMM_ECXDDD 175 ; 176 CNHSTAT(ECXDFN) ; Get CNH (Contract Nursing Home) status 177 ; 178 ; Input: 179 ; ECXDFN - Patient DFN 180 ; 181 ;Output: 182 ; CNH status (YES/NO) 183 ; 184 N ECXCNH 185 S ECXDFN=+$G(ECXDFN) 186 S ECXCNH=$P($G(^DPT(ECXDFN,"NHC")),U) 187 Q $S(ECXCNH="Y":"YES",ECXCNH="N":"NO",1:"") 188 ; 189 CANC(ECXNOR,ECXTMOR) ; Get Surgery Cancelled/Aborted Status 190 ; 191 ; Function called after determining CANCEL DATE in SURGERY record exists 192 ; 193 ; Input: 194 ; ECXNOR - Non-OR DSS ID 195 ; ECXTMOR - Time Pat in OR 196 ; 197 ;Output: 198 ; Cancelled/aborted status (C/A) 199 ; 200 N ECXCANC 201 S ECXCANC="" 202 S ECXNOR=$G(ECXNOR) 203 ; 204 ;- If Non-OR DSS ID or Time Pat in OR, ECXCANC = "A" else = "C" 205 D 206 . I ECXNOR'=""&(ECXNOR'="UNKNOWN") S ECXCANC="A" Q 207 . I +$G(ECXTMOR) S ECXCANC="A" Q 208 . S ECXCANC="C" 209 Q ECXCANC 210 ; 211 ECSCOST(ECXCOST) ;Get ECS extract stop code based on cost center 212 ; 213 ; 214 ; Input: 215 ; ECXCOST - ECS extract cost center 216 ; 217 ;Output: 218 ; ECS extract stop code 219 ; 220 N ECXFND,ECXSTOP,I 221 S ECXFND=0 222 S ECXSTOP="" 223 S ECXCOST=+$G(ECXCOST) 224 D 225 . I 'ECXCOST Q 226 . F I=1:1 Q:ECXFND!($P($T(COST+I),";;",2)="END") D 227 .. I ECXCOST=$P($T(COST+I),";;",2) S ECXSTOP=$P($T(COST+I),";;",3),ECXFND=1 228 Q ECXSTOP 229 ; 230 COST ;- ECS Cost Center and stop code 231 ;;833100;;652 232 ;;833200;;653 233 ;;833300;;681 234 ;;834100;;651 235 ;;834200;;650 236 ;;834300;;681 237 ;;834400;;654 238 ;;834500;;681 239 ;;834600;;681 240 ;;834700;;681 241 ;;834800;;681 242 ;;834900;;681 243 ;;836100;;654 244 ;;836200;;654 245 ;;END 246 ; 247 HNCI(ECXDFN) ; Get head & neck cancer indicator 248 ; 249 ; Input: 250 ; ECXDFN - Patient DFN 251 ; 252 ;Output: 253 ; Head/Neck CA DX (Y/N) 254 ; 255 N ECXHNCI,DGNT 256 S ECXHNCI="" 257 S ECXDFN=+$G(ECXDFN) I ECXDFN D 258 .I $$GETCUR^DGNTAPI(ECXDFN,"DGNT") S ECXHNCI=$P(DGNT("HNC"),U) 259 Q ECXHNCI 260 ; 261 TSMAP(ECXTS) ;Determines DSS Identifier for the following observation 262 ; treating specialty 263 ; Input: 264 ; ECXTS - Observation Treating Specialty 265 ; 266 ; Output: 267 ; DSS Identifier (Stop Code) 268 ; 269 N TS,SC,I 270 S TS="^18^23^24^36^41^65^94^",SC="^293^295^290^294^296^291^292^" 271 F I=1:1:$L(TS) Q:$P(TS,"^",I)=ECXTS 272 Q $P(SC,"^",I)_"000" -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXUTL5.m
r613 r623 1 ECXUTL5 ;ALB/JRC - Utilities for DSS Extracts ; 10/17/07 3:49pm 2 ;;3.0;DSS EXTRACTS;**71,84,92,103,105**;Dec 22, 1997;Build 70 3 ; 4 REPEAT(CHAR,TIMES) ;REPEAT A STRING 5 ;INPUT : CHAR - Character to repeat 6 ; TIMES - Number of times to repeat CHAR 7 ;OUTPUT : s - String of CHAR that is TIMES long 8 ; "" - Error (bad input) 9 ; 10 ;CHECK INPUT 11 Q:($G(CHAR)="") "" 12 Q:((+$G(TIMES))=0) "" 13 ;RETURN STRING 14 Q $TR($J("",TIMES)," ",CHAR) 15 INSERT(INSTR,OUTSTR,COLUMN,LENGTH) ;INSERT A STRING INTO ANOTHER 16 ;INPUT : INSTR - String to insert 17 ; OUTSTR - String to insert into 18 ; COLUMN - Where to begin insertion (defaults to end of OUTSTR) 19 ; LENGTH - Number of characters to clear from OUTSTR 20 ; (defaults to length of INSTR) 21 ;OUTPUT : s - INSTR will be placed into OUTSTR starting at COLUMN 22 ; using LENGTH characters 23 ; "" - Error (bad input) 24 ; 25 ;NOTE : This module is based on $$SETSTR^VALM1 26 ; 27 ;CHECK INPUT 28 Q:('$D(INSTR)) "" 29 Q:('$D(OUTSTR)) "" 30 S:('$D(COLUMN)) COLUMN=$L(OUTSTR)+1 31 S:('$D(LENGTH)) LENGTH=$L(INSTR) 32 ;DECLARE VARIABLES 33 N FRONT,END 34 S FRONT=$E((OUTSTR_$J("",COLUMN-1)),1,(COLUMN-1)) 35 S END=$E(OUTSTR,(COLUMN+LENGTH),$L(OUTSTR)) 36 ;INSERT STRING 37 Q FRONT_$E((INSTR_$J("",LENGTH)),1,LENGTH)_END 38 TYPE(DFN) ;Determine patient type DBIA #2511 39 ; input 40 ; DFN = patient ien 41 ; 42 ; output 43 ; ECXPTYPE = patient type external value from fle 391 44 ; 45 ; AC = ACTIVE DUTY MI = MILITARY RETIREE 46 ; AL = ALLIED VETERAN NO = NON-VETERAN (OTHER) 47 ; CO = COLLATERAL NS = NSC VETERAN 48 ; EM = EMPLOYEE SC = SC VETERAN 49 ; IN = INELIGIBLE TR = TRICARE 50 ; return value 0 if no data found, 1 if data found 51 ; 52 N TYPE,ECXPTYPE 53 ;Check input 54 Q:'$D(DFN) "" 55 S (TYPE,ECXPTYPE)="" 56 S TYPE=$G(^DPT(DFN,"TYPE")) 57 I 'TYPE Q ECXPTYPE 58 S ECXPTYPE=$P($G(^DG(391,TYPE,0)),U,1) 59 S ECXPTYPE=$E(ECXPTYPE,1,2) 60 Q ECXPTYPE 61 CVEDT(DFN,DATE) ;Determine patient CV status DBIA #4156 62 ; input 63 ; DFN = patient ien 64 ; 65 ; output 66 ; ECXCVE = combat veteran status eligibility 67 ; ECXCVEDT = combat veteran eligibility end date 68 ; ECXCVENC = combat veteran encounter 69 ;Initialize variables 70 N CVSTAT 71 S (CVSTAT,ECXCVE,ECXCVEDT,ECXCVENC)="" 72 ;Check input 73 Q:'$D(DFN) 0 74 ;Call CV API 75 S CVSTAT=$$CVEDT^DGCV(DFN,DATE) 76 I CVSTAT<1 Q 0 77 ;Veteran been given CV eligibility 78 S ECXCVE=$S($P(CVSTAT,U,3)=1:"Y",$P(CVSTAT,U,3)=0:"E",1:"") 79 ;Save CV eligibility end date and convert from FM to HL7 format 80 S ECXCVEDT=$P(CVSTAT,U,2) 81 S ECXCVEDT=$$FMTHL7^XLFDT(ECXCVEDT) 82 ;Is the veteran eligible for CV in the date of encounter 83 S ECXCVENC=$S($P(CVSTAT,U,3)=1:"Y",1:"") 84 Q 1 85 NPRF ;National patient record flags DBIA #3860 86 N ECXARR,FLG 87 S ECXNPRFI="",CNT=$$GETACT^DGPFAPI(ECXDFN,"ECXARR"),FLG="" 88 I 'CNT Q 89 F I=1:1:CNT D Q:FLG 90 .I ECXARR(I,"CATEGORY")["NATIONAL" S ECXNPRFI="Y",FLG=1 91 Q 92 RXPTST(K) ;Rx patient status DBIA #2511 93 N ECXDIC,STAT 94 S (ECXDIC,STAT)="" 95 ;Check input 96 Q:'$D(K) STAT 97 S DA=K,DIC="^PS(53,",DIQ(0)="I",DIQ="ECXDIC",DR="6" 98 D EN^DIQ1 99 S STAT=$G(ECXDIC(53,K,6,"I")) 100 S STAT=$S(STAT=1:"SC",STAT=2:"AA",STAT=3:"OTH",STAT=4:"INP",STAT=5:"NON",1:"") 101 Q STAT 102 NONVAP(K) ;Non-va prescriber DBIA #10060 103 N ECXDIC,NONVAP 104 S (ECXDIC,NONVAP)="" 105 Q:'$D(K) NONVAP 106 S DA=K,DIC="^VA(200,",DIQ(0)="I",DIQ="ECXDIC",DR="53.91" 107 D EN^DIQ1 108 S NONVAP=$G(ECXDIC(200,K,53.91,"I")) 109 I NONVAP S NONVAP="Y" 110 Q NONVAP 111 DOIVPO(K,L) ;Add destination for outpatient ivp orders 112 ; Input K - DFN 113 ; L - Order # from Pharmacy Patient File (#55) 114 ; 115 ; Output ordering stop code 116 ; 117 N ECXDIC,ECXDICA,ECXDICB,DOIVPO,CLINIC,SCODE,DIC,DIQ,DR,DA 118 S (ECXDIC,ECXDICA,ECXDICB,DOIVPO,CLINIC,SCODE)="" 119 ;Check input 120 Q:'K!'(L) SCODE 121 ;Check treating specialty 122 S SCODE=$$TSSC($G(ECXTS)) I SCODE>0 Q SCODE 123 ;Go to pharmacy patient file (#55) and return value of field (#136) 124 S DIC=55,DIQ(0)="I",DIQ="ECXDIC",DR="100",DR(55.01)="136",DA=K,DA(55.01)=L 125 D EN^DIQ1 126 S CLINIC=$G(ECXDIC(55.01,L,136,"I")) 127 I 'CLINIC Q SCODE 128 ;Get stop code pointer to file 40.7 from file 44 129 S DIC="^SC(",DIQ(0)="I",DIQ="ECXDICA",DR="8",DA=CLINIC D EN^DIQ1 130 S SCODE=ECXDICA(44,CLINIC,8,"I") 131 ;Get stop code external value 132 S DIC="^DIC(40.7,",DIQ(0)="E",DIQ="ECXDICB",DR="1",DA=SCODE D EN^DIQ1 133 S SCODE=$G(ECXDICB(40.7,SCODE,1,"E")) 134 Q SCODE 135 ; 136 DOUDO(K,L) ;Add destination for outpatient udp orders 137 ; Input K - DFN 138 ; L - Order # from Pharmacy Patient File (#55) 139 ; 140 ; Output ordering stop code 141 ; 142 N ECXDIC,ECXDICA,ECXDICB,DOIVPO,CLINIC,SCODE,DIC,DIQ,DR,DA 143 S (ECXDIC,ECXDICA,ECXDICB,DOIVPO,CLINIC,SCODE)="" 144 ;Check treating specialty 145 S SCODE=$$TSSC($G(ECXTS)) I SCODE>0 Q SCODE 146 ;Check input 147 Q:'K!'(L) SCODE 148 S DIC=55,DIQ(0)="I",DIQ="ECXDIC",DR="62",DR(55.06)="130",DA=K,DA(55.06)=L 149 D EN^DIQ1 150 S CLINIC=$G(ECXDIC(55.06,L,130,"I")) 151 I 'CLINIC Q SCODE 152 ;Get stop code pointer to file 40.7 from file 44 153 S DIC="^SC(",DIQ(0)="I",DIQ="ECXDICA",DR="8",DA=CLINIC D EN^DIQ1 154 S SCODE=ECXDICA(44,CLINIC,8,"I") 155 ;Get stop code external value 156 S DIC="^DIC(40.7,",DIQ(0)="E",DIQ="ECXDICB",DR="1",DA=SCODE D EN^DIQ1 157 S SCODE=$G(ECXDICB(40.7,SCODE,1,"E")) 158 Q SCODE 159 ; 160 PHAAPI(DRUG) ;Call Pharmacy drug file API dbia 4483 161 ; Input: drug file (#50) ien 162 ; 163 ; Output: generic name ^ classification ^ ndc ^ dea hand 164 ; ^ ndf file entry # ^ psndf va product entry ^ 165 ; price per disp unit ^ dispense unit 166 ; 167 ;Initialize variables and scratch global 168 N NAME,CLASS,NDC,INV,NDF,P1,P3,PPDU,UNIT,ARRAY,DATA 169 S (NAME,CLASS,NDC,INV,NDF,P1,P3,PPDU,ARRAY,DATA)="" 170 S ARRAY="^TMP($J,""ECXLIST"")" 171 K @ARRAY 172 D DATA^PSS50(DRUG,,,,,"ECXLIST") 173 I @ARRAY@(0)'>0 Q "^^^^^^" 174 S NAME=@ARRAY@(DRUG,.01),CLASS=@ARRAY@(DRUG,2),NDC=@ARRAY@(DRUG,31) 175 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) 176 K @ARRAY 177 Q NAME_U_CLASS_U_NDC_U_INV_U_P1_U_P3_U_PPDU_U_UNIT 178 ; 179 TSSC(X) ;Check treating specialty (ts) and if ts equals any of the following 180 ;18,23,24,36,41,65,94 then assign predefined code and return value 181 ; 182 ; Input: treating specialty 183 ; Output: Ordering stop code 184 ; 185 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:"") 186 Q CODE 187 ; 188 PSJ59P5(X) ;Get iv room division 189 ; Input X - iv room ien 190 ; 191 ; Output - field .02 division 192 ;Init variables 193 N DIV S DIV="" 194 ;Check input 195 I 'X Q DIV 196 D ALL^PSJ59P5(X,,"ECXDIV") 197 S DIV=$P($G(^TMP($J,"ECXDIV",X,.02)),U) 198 K ^TMP($J,"ECXDIV") 199 Q DIV 200 ; 201 SCRX(IEN) ;Service connected prescription 202 ;Init variables 203 N DIC,DR,DA,ECXDIQ 204 ;Check input 205 I '$G(IEN) Q "" 206 S DIC=52,DR="116",DA=IEN,DIQ="ECXDIQ" 207 D DIQ^PSODI(DIC,DIC,DR,DA,DIQ) 208 Q $S($G(ECXDIQ(52,DA,116))="YES":"Y",$G(ECXDIQ(52,DA,116))="NO":"N",1:"") 209 ; 210 SSN(SSN,FILE) ; extended validation of ssn 211 ; input: ssn - social security number to validate 212 ; file - optional "", 2 or 67, the only check is for 213 ; reference lab file (#67) in which case ssn 214 ; "000123456" is considered a valid ssn. 215 ; output: 0 - test patient or invalid ssn 216 ; 1 - valid ssn 217 ; 218 ;check input 219 I $G(SSN)']"" Q 0 220 S FILE=$G(FILE) 221 I (FILE=67)&(SSN="000123456") Q 1 222 I "89"[$E(SSN) Q 0 223 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 224 Q 1 1 ECXUTL5 ;ALB/JRC - Utilities for DSS Extracts ; 01/18/07 9:04am 2 ;;3.0;DSS EXTRACTS;**71,84,92,103**;Dec 22, 1997;Build 1 3 ; 4 REPEAT(CHAR,TIMES) ;REPEAT A STRING 5 ;INPUT : CHAR - Character to repeat 6 ; TIMES - Number of times to repeat CHAR 7 ;OUTPUT : s - String of CHAR that is TIMES long 8 ; "" - Error (bad input) 9 ; 10 ;CHECK INPUT 11 Q:($G(CHAR)="") "" 12 Q:((+$G(TIMES))=0) "" 13 ;RETURN STRING 14 Q $TR($J("",TIMES)," ",CHAR) 15 INSERT(INSTR,OUTSTR,COLUMN,LENGTH) ;INSERT A STRING INTO ANOTHER 16 ;INPUT : INSTR - String to insert 17 ; OUTSTR - String to insert into 18 ; COLUMN - Where to begin insertion (defaults to end of OUTSTR) 19 ; LENGTH - Number of characters to clear from OUTSTR 20 ; (defaults to length of INSTR) 21 ;OUTPUT : s - INSTR will be placed into OUTSTR starting at COLUMN 22 ; using LENGTH characters 23 ; "" - Error (bad input) 24 ; 25 ;NOTE : This module is based on $$SETSTR^VALM1 26 ; 27 ;CHECK INPUT 28 Q:('$D(INSTR)) "" 29 Q:('$D(OUTSTR)) "" 30 S:('$D(COLUMN)) COLUMN=$L(OUTSTR)+1 31 S:('$D(LENGTH)) LENGTH=$L(INSTR) 32 ;DECLARE VARIABLES 33 N FRONT,END 34 S FRONT=$E((OUTSTR_$J("",COLUMN-1)),1,(COLUMN-1)) 35 S END=$E(OUTSTR,(COLUMN+LENGTH),$L(OUTSTR)) 36 ;INSERT STRING 37 Q FRONT_$E((INSTR_$J("",LENGTH)),1,LENGTH)_END 38 TYPE(DFN) ;Determine patient type DBIA #2511 39 ; input 40 ; DFN = patient ien 41 ; 42 ; output 43 ; ECXPTYPE = patient type external value from fle 391 44 ; 45 ; AC = ACTIVE DUTY MI = MILITARY RETIREE 46 ; AL = ALLIED VETERAN NO = NON-VETERAN (OTHER) 47 ; CO = COLLATERAL NS = NSC VETERAN 48 ; EM = EMPLOYEE SC = SC VETERAN 49 ; IN = INELIGIBLE TR = TRICARE 50 ; return value 0 if no data found, 1 if data found 51 ; 52 N TYPE,ECXPTYPE 53 ;Check input 54 Q:'$D(DFN) "" 55 S (TYPE,ECXPTYPE)="" 56 S TYPE=$G(^DPT(DFN,"TYPE")) 57 I 'TYPE Q ECXPTYPE 58 S ECXPTYPE=$P($G(^DG(391,TYPE,0)),U,1) 59 S ECXPTYPE=$E(ECXPTYPE,1,2) 60 Q ECXPTYPE 61 CVEDT(DFN,DATE) ;Determine patient CV status DBIA #4156 62 ; input 63 ; DFN = patient ien 64 ; 65 ; output 66 ; ECXCVE = combat veteran status eligibility 67 ; ECXCVEDT = combat veteran eligibility end date 68 ; ECXCVENC = combat veteran encounter 69 ;Initialize variables 70 N CVSTAT 71 S (CVSTAT,ECXCVE,ECXCVEDT,ECXCVENC)="" 72 ;Check input 73 Q:'$D(DFN) 0 74 ;Call CV API 75 S CVSTAT=$$CVEDT^DGCV(DFN,DATE) 76 I CVSTAT<1 Q 0 77 ;Veteran been given CV eligibility 78 S ECXCVE=$S($P(CVSTAT,U,3)=1:"Y",$P(CVSTAT,U,3)=0:"E",1:"") 79 ;Save CV eligibility end date and convert from FM to HL7 format 80 S ECXCVEDT=$P(CVSTAT,U,2) 81 S ECXCVEDT=$$FMTHL7^XLFDT(ECXCVEDT) 82 ;Is the veteran eligible for CV in the date of encounter 83 S ECXCVENC=$S($P(CVSTAT,U,3)=1:"Y",1:"") 84 Q 1 85 NPRF ;National patient record flags DBIA #3860 86 N ECXARR,FLG 87 S ECXNPRFI="",CNT=$$GETACT^DGPFAPI(ECXDFN,"ECXARR"),FLG="" 88 I 'CNT Q 89 F I=1:1:CNT D Q:FLG 90 .I ECXARR(I,"CATEGORY")["NATIONAL" S ECXNPRFI="Y",FLG=1 91 Q 92 RXPTST(K) ;Rx patient status DBIA #2511 93 N ECXDIC,STAT 94 S (ECXDIC,STAT)="" 95 ;Check input 96 Q:'$D(K) STAT 97 S DA=K,DIC="^PS(53,",DIQ(0)="I",DIQ="ECXDIC",DR="6" 98 D EN^DIQ1 99 S STAT=$G(ECXDIC(53,K,6,"I")) 100 S STAT=$S(STAT=1:"SC",STAT=2:"AA",STAT=3:"OTH",STAT=4:"INP",STAT=5:"NON",1:"") 101 Q STAT 102 NONVAP(K) ;Non-va prescriber DBIA #10060 103 N ECXDIC,NONVAP 104 S (ECXDIC,NONVAP)="" 105 Q:'$D(K) NONVAP 106 S DA=K,DIC="^VA(200,",DIQ(0)="I",DIQ="ECXDIC",DR="53.91" 107 D EN^DIQ1 108 S NONVAP=$G(ECXDIC(200,K,53.91,"I")) 109 I NONVAP S NONVAP="Y" 110 Q NONVAP 111 DOIVPO(K,L) ;Add destination for outpatient ivp orders 112 ; Input K - DFN 113 ; L - Order # from Pharmacy Patient File (#55) 114 ; 115 ; Output ordering stop code 116 ; 117 N ECXDIC,ECXDICA,ECXDICB,DOIVPO,CLINIC,SCODE,DIC,DIQ,DR,DA 118 S (ECXDIC,ECXDICA,ECXDICB,DOIVPO,CLINIC,SCODE)="" 119 ;Check input 120 Q:'K!'(L) SCODE 121 ;Check treating specialty 122 S SCODE=$$TSSC($G(ECXTS)) I SCODE>0 Q SCODE 123 ;Go to pharmacy patient file (#55) and return value of field (#136) 124 S DIC=55,DIQ(0)="I",DIQ="ECXDIC",DR="100",DR(55.01)="136",DA=K,DA(55.01)=L 125 D EN^DIQ1 126 S CLINIC=$G(ECXDIC(55.01,L,136,"I")) 127 I 'CLINIC Q SCODE 128 ;Get stop code pointer to file 40.7 from file 44 129 S DIC="^SC(",DIQ(0)="I",DIQ="ECXDICA",DR="8",DA=CLINIC D EN^DIQ1 130 S SCODE=ECXDICA(44,CLINIC,8,"I") 131 ;Get stop code external value 132 S DIC="^DIC(40.7,",DIQ(0)="E",DIQ="ECXDICB",DR="1",DA=SCODE D EN^DIQ1 133 S SCODE=$G(ECXDICB(40.7,SCODE,1,"E")) 134 Q SCODE 135 ; 136 DOUDO(K,L) ;Add destination for outpatient udp orders 137 ; Input K - DFN 138 ; L - Order # from Pharmacy Patient File (#55) 139 ; 140 ; Output ordering stop code 141 ; 142 N ECXDIC,ECXDICA,ECXDICB,DOIVPO,CLINIC,SCODE,DIC,DIQ,DR,DA 143 S (ECXDIC,ECXDICA,ECXDICB,DOIVPO,CLINIC,SCODE)="" 144 ;Check treating specialty 145 S SCODE=$$TSSC($G(ECXTS)) I SCODE>0 Q SCODE 146 ;Check input 147 Q:'K!'(L) SCODE 148 S DIC=55,DIQ(0)="I",DIQ="ECXDIC",DR="62",DR(55.06)="130",DA=K,DA(55.06)=L 149 D EN^DIQ1 150 S CLINIC=$G(ECXDIC(55.06,L,130,"I")) 151 I 'CLINIC Q SCODE 152 ;Get stop code pointer to file 40.7 from file 44 153 S DIC="^SC(",DIQ(0)="I",DIQ="ECXDICA",DR="8",DA=CLINIC D EN^DIQ1 154 S SCODE=ECXDICA(44,CLINIC,8,"I") 155 ;Get stop code external value 156 S DIC="^DIC(40.7,",DIQ(0)="E",DIQ="ECXDICB",DR="1",DA=SCODE D EN^DIQ1 157 S SCODE=$G(ECXDICB(40.7,SCODE,1,"E")) 158 Q SCODE 159 ; 160 PHAAPI(DRUG) ;Call Pharmacy drug file API dbia 4483 161 ; Input: drug file (#50) ien 162 ; 163 ; Output: generic name ^ classification ^ ndc ^ dea hand 164 ; ^ ndf file entry # ^ psndf va product entry ^ 165 ; price per disp unit ^ dispense unit 166 ; 167 ;Initialize variables and scratch global 168 N NAME,CLASS,NDC,INV,NDF,P1,P3,PPDU,UNIT,ARRAY,DATA 169 S (NAME,CLASS,NDC,INV,NDF,P1,P3,PPDU,ARRAY,DATA)="" 170 S ARRAY="^TMP($J,""ECXLIST"")" 171 K @ARRAY 172 D DATA^PSS50(DRUG,,,,,"ECXLIST") 173 I @ARRAY@(0)'>0 Q "^^^^^^" 174 S NAME=@ARRAY@(DRUG,.01),CLASS=@ARRAY@(DRUG,2),NDC=@ARRAY@(DRUG,31) 175 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) 176 K @ARRAY 177 Q NAME_U_CLASS_U_NDC_U_INV_U_P1_U_P3_U_PPDU_U_UNIT 178 ; 179 TSSC(X) ;Check treating specialty (ts) and if ts equals any of the following 180 ;18,23,24,36,41,65,94 then assign predefined code and return value 181 ; 182 ; Input: treating specialty 183 ; Output: Ordering stop code 184 ; 185 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:"") 186 Q CODE 187 ; 188 PSJ59P5(X) ;Get iv room division 189 ; Input X - iv room ien 190 ; 191 ; Output - field .02 division 192 ;Init variables 193 N DIV S DIV="" 194 ;Check input 195 I 'X Q DIV 196 D ALL^PSJ59P5(X,,"ECXDIV") 197 S DIV=$P($G(^TMP($J,"ECXDIV",X,.02)),U) 198 K ^TMP($J,"ECXDIV") 199 Q DIV 200 ; 201 SCRX(IEN) ;Service connected prescription 202 ;Init variables 203 N DIC,DR,DA,ECXDIQ 204 ;Check input 205 I '$G(IEN) Q "" 206 S DIC=52,DR="116",DA=IEN,DIQ="ECXDIQ" 207 D DIQ^PSODI(DIC,DIC,DR,DA,DIQ) 208 Q $S($G(ECXDIQ(52,DA,116))="YES":"Y",$G(ECXDIQ(52,DA,116))="NO":"N",1:"") -
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXUTL6.m
r613 r623 1 ECXUTL6 ;ALB/JRC - Utilities for DSS Extracts ; 11/28/07 11:34am 2 ;;3.0;DSS EXTRACTS;**92,105**;Dec 22, 1997;Build 70 3 ; 4 NUTKEY(P,D) ;Generate n&fs feeder key 5 ;Required variables 6 ; p - diet type production diet, standing orders, supplemental 7 ; feedings, or tube feedings. 8 ; d - diet ien from files 116.2, 118.3, 118, or 118.2 9 ;Check input 10 I $G(P)=""!'$G(D) Q "" 11 ;Init variables 12 N PRO,IENS,CODE,DIET 13 S (PRO,IENS,CODE,DIET)=0 14 S PRO=$O(^ECX(728.45,"B",P,PRO)) 15 S CODE=D_$S(P="PD":";FH(116.2,",P="SO":";FH(118.3,",P="SF":";FH(118,",P="TF":";FH(118.2,",1:"") 16 S DIET=0,DIET=$O(^ECX(728.45,+PRO,1,"B",CODE,DIET)) 17 S IENS=""_DIET_","_PRO_","_"" 18 Q $$GET1^DIQ(728.451,IENS,1) 19 ; 20 NUTLOC(P,D,FPD,FDD,FPF,DLT,DFL) ;Define nutrition fields 21 ;Required variables 22 ; p - patient status, inpatient or outpatient 23 ; 24 ; d - diet type production diet, standing orders, supplemental 25 ; feedings, or tube feedings. 26 ; Output: food production division, food delivery division, food 27 ; production facility, food delivery type, delivery feeder 28 ; location 29 ;Init variables 30 N WARD,TRSVP,CRSVP,OPLOC,MASWARD 31 S (CRSVP,TRSVP)=0,(WARD,DLT,DFL,MASWARD)="" 32 S OPLOC="" 33 ;Check input 34 I $G(P)=""!($G(D)="")!'($G(FHDFN)) Q "" 35 ;Get food production facility for inpatient, use 115.1.13 (dietetic 36 ;ward) field which points 119.6 (nutrition location), field 3 (tray 37 ;service point) or field 4 (cafeteria service point), which points to 38 ;119.72 (production facility) field 2. 39 I P="INP" D 40 .S WARD=$P($G(^FHPT(FHDFN,"A",+ECXADM,0)),U,8) 41 .S TRSVP=$$GET1^DIQ(119.6,WARD,3,"I") 42 .S CRSVP=$$GET1^DIQ(119.6,WARD,4,"I") 43 .;Get divisions 44 .D GETDIV 45 .Q 46 ; 47 ;Get food production facility for outpatient recurring meal, use 48 ;115.16.2 (outpatient location) which points to file 119.6 (nutrition 49 ;location) field 3 (tray service point) or field 4 (cafeteria service 50 ;point), which points to 119.72 (production facility) field 2. 51 I P["OP",D["RM" D 52 .S OPLOC=""_$P(NODE,U,3)_","_"",TRSVP=$$GET1^DIQ(119.6,OPLOC,3,"I") 53 .D GETDIV 54 .Q 55 ; 56 ;Get food production facility for outpatient tube feeding, use 57 ;115.16.2 (outpatient location) then use 119.6 nutrition location 58 ;which points to 119.72 field 2. 59 I P["OP",D["TF" D 60 .S OPLOC=""_$P(^TMP($J,"FH",DATE,FHDFN,NUMBER,"RM"),U,3)_","_"" 61 .S TRSVP=$$GET1^DIQ(119.6,OPLOC,3,"I") 62 .;Get delivery division 63 .D GETDIV 64 .Q 65 ; 66 ;Get food production facility for special meals, use 115.17.2 67 ;location field 2 which is a pointer to 119.6 (nutrition location) 68 ;which points to 119.72 via field 2 (tray service point) which points 69 ;to file 119.71 (production facility) field 2. 70 I P["OP",D["SM" D 71 .S OPLOC=""_$P(NODE,U,3)_","_"" 72 .S TRSVP=$$GET1^DIQ(119.6,OPLOC,3,"I") 73 .;Get delivery division 74 .D GETDIV 75 .Q 76 ; 77 ;Get food production facility for outpatient guest meals, use 78 ;115.18.4 (outpatient location) then use 119.6 nutrition location 79 ;which points to 119.72 (production facility) field 2. 80 I P["OP",D["GM" D 81 .S OPLOC=""_$P(NODE,U,5)_","_"",TRSVP=$$GET1^DIQ(119.6,OPLOC,3,"I") 82 .S FPF=$$GET1^DIQ(119.72,""_TRSVP_","_"",2,"I") 83 .;Get delivery division 84 .D GETDIV 85 .Q 86 ; 87 ;Get delivery location type for patients; with inpatients the type of 88 ;service needs to be pulled from the admission node, with outpatients 89 ;the type of service needs to be pulled from different nodes and use 90 ;field 101 of Nutrition Location file (#119.6). Delivery location 91 ;types only set for the following meals: 92 ; Inpatient with a production diet 93 ; Outpatient with a recurring meal 94 ; Outpatient with a special meal 95 ; Outpatient with a guest meal 96 ; all other meals are null 97 I P="INP",D="PD" D 98 .S DLT=$P($G(NODE),U,8) 99 I P="OP",((D="RM")!(D="SM")) D 100 .S DLT=$E($$GET1^DIQ(119.6,""_$P(NODE,U,3)_","_"",101,"E"),1) 101 I P="OP",D="GM" D 102 .S DLT=$E($$GET1^DIQ(119.6,""_$P(NODE,U,5)_","_"",101,"E"),1) 103 ; 104 ;Delivery feeder location 105 I DLT="C" D 106 .S DFL=$E($$GET1^DIQ(119.6,WARD,4,"E"),1,10) 107 .S IEN=$$GET1^DIQ(119.72,+CRSVP,2,"I") 108 .S IEN=""_IEN_";FH(119.71," 109 .S FPF=$O(^ECX(728.46,"B",IEN,FPF)) 110 .S FPF=$E($$GET1^DIQ(728.46,FPF,.01,"E"),1,10) 111 I (DLT["T")!(DLT["D") D 112 .I P="INP" D 113 ..S MASWARD=$O(^FH(119.6,+WARD,"W","B",0)) 114 ..S DFL=$$GET1^DIQ(42,+MASWARD,44,"I") 115 .I P="OP" D 116 ..S DFL=$O(^FH(119.6,+OPLOC,"L","B",0)) 117 I (DLT=""),"SFTFSO"[D D 118 .S DFL=$S(TRSVP:$$GET1^DIQ(119.6,WARD,3,"E"),1:$$GET1^DIQ(119.6,WARD,4,"E")) 119 Q 1 120 ; 121 GETDIV ;Get divisions and food production facility 122 ;Init variables 123 N IEN,SIEN 124 S (FDD,FPF,FPD)="" 125 S IEN=$$GET1^DIQ(119.72,+TRSVP,2,"I") 126 Q:'IEN 127 ;Get delivery division 128 S SIEN=""_+TRSVP_";FH(119.72," 129 S FDD=$O(^ECX(728.46,"B",SIEN,FDD)) 130 S FDD=""_$$GET1^DIQ(728.46,FDD,1,"I")_","_"" 131 S FDD=$$GET1^DIQ(4,FDD,99,"E") 132 ;Get production division and food production facility 133 S IEN=""_IEN_";FH(119.71," 134 S FPF=$O(^ECX(728.46,"B",IEN,FPF)) 135 S FPD=""_$$GET1^DIQ(728.46,FPF,1,"I")_","_"" 136 S FPD=$$GET1^DIQ(4,FPD,99,"E") 137 S FPF=$E($$GET1^DIQ(728.46,FPF,.01,"E"),1,10) 138 Q 139 ; 140 SUR(CRST,STCD,CLINIC) ;Surgery stop codes and clinic (outpatients only) 141 ;Init variables 142 S (CRST,STCD,CLINIC)="" 143 ;Quit if not outpatient 144 Q:$P(EC0,U,12)'="O" "" 145 ;Get stop codes (outpatient only) 146 I $P(EC0,U,12)="O" D 147 .;Get credit stop code (outpatient only) 148 .S CRST=""_$$GET1^DIQ(40.7,""_$$GET1^DIQ(44,$$GET1^DIQ(137.45,$P(EC0,U,4),2,"I")_","_""_","_"",2503,"I")_","_"",1,"E") 149 .;Get stop code (outpatient only) 150 .S STCD=""_$$GET1^DIQ(40.7,""_$$GET1^DIQ(44,$$GET1^DIQ(137.45,$P(EC0,U,4),2,"I")_","_""_","_"",8,"I")_","_"",1,"E") 151 ;Clinic for non-or case use associated clinic else non-or location 152 ;If non-or case 153 I $P($G(ECNO),U)="Y" S CLINIC=$S($P(EC0,U,21):$P(EC0,U,21),1:$P(ECNO,U,2)) 154 ;Get stop codes non-or cases 155 I $P($G(ECNO),U)="Y" D 156 .;Get credit stop code for non-or case 157 .S CRST=$$GET1^DIQ(40.7,$$GET1^DIQ(44,CLINIC,2503,"I"),1,"E") 158 .;Get stop code for non-or case 159 .S STCD=$$GET1^DIQ(40.7,$$GET1^DIQ(44,CLINIC,8,"I"),1,"E") 160 ;Clinic, not a non-or case use surgical specialty associated clinic 161 I $P($G(ECNO),U)'="Y" S CLINIC=$$GET1^DIQ(137.45,+$P(EC0,U,4),2,"I") 162 Q 1 163 ; 164 SURPODX(PRODX,PODX1,PODX2,PODX3,PODX4,PODX5) ;Get postop diagnosis codes 165 ;Init variables 166 N CODE,I,PODX 167 S (PRODX,PODX1,PODX2,PODX3,PODX4,PODX5)="",CODE=0 168 ;Check input 169 Q:'$D(DATAOP) 0 170 ;Get principal postop dx code 171 S PRODX=$$GET1^DIQ(80,$P(DATAOP,U,3),.01) 172 ;Get other postop dx codes 173 S (CODE,I)=0 F S CODE=$O(^SRO(136,ECD0,4,CODE)) Q:'CODE Q:I>5 D 174 .S I=I+1,PODX="PODX"_I,@PODX=$$GET1^DIQ(80,$P(^SRO(136,ECD0,4,CODE,0),U),.01) 175 Q 1 1 ECXUTL6 ;ALB/JRC - Utilities for DSS Extracts ; 11/2/06 8:30am 2 ;;3.0;DSS EXTRACTS;**92**;Dec 22, 1997;Build 30 3 ; 4 NUTKEY(P,D) ;Generate n&fs feeder key 5 ;Required variables 6 ; p - diet type production diet, standing orders, supplemental 7 ; feedings, or tube feedings. 8 ; d - diet ien from files 116.2, 116.3, 118, or 118.2 9 ;Check input 10 I $G(P)=""!'$G(D) Q "" 11 ;Init variables 12 N PRO,IENS,CODE,DIET 13 S (PRO,IENS,CODE,DIET)=0 14 S PRO=$O(^ECX(728.45,"B",P,PRO)) 15 S CODE=D_$S(P="PD":";FH(116.2,",P="SO":";FH(116.3,",P="SF":";FH(118,",P="TF":";FH(118.2,",1:"") 16 S DIET=0,DIET=$O(^ECX(728.45,+PRO,1,"B",CODE,DIET)) 17 S IENS=""_DIET_","_PRO_","_"" 18 Q $$GET1^DIQ(728.451,IENS,1) 19 ; 20 NUTLOC(P,D,FPD,FDD,FPF,DLT,DFL) ;Define nutrition fields 21 ;Required variables 22 ; p - patient status, inpatient or outpatient 23 ; 24 ; d - diet type production diet, standing orders, supplemental 25 ; feedings, or tube feedings. 26 ; Output: food production division, food delivery division, food 27 ; production facility, food delivery type, delivery feeder 28 ; location 29 ;Init variables 30 N WARD,TRSVP,OPLOC,MASWARD 31 S TRSVP=0,(WARD,ECXDLT,ECXDFL,MASWARD)="" 32 S OPLOC="" 33 ;Check input 34 I $G(P)=""!($G(D)="")!'($G(FHDFN)) Q "" 35 ;Get food production facility for inpatient, use 115.1.13 (dietetic 36 ;ward) field which points 119.6 (nutrition location), field 3 (tray 37 ;service point) or field 4 (cafeteria service point), which points to 38 ;119.72 (production facility) field 2. 39 I P="INP" D 40 .S WARD=$P($G(^FHPT(FHDFN,"A",ECXADM,0)),U,8) 41 .S TRSVP=$$GET1^DIQ(119.6,WARD,3,"I") 42 .;Get divisions 43 .D GETDIV 44 .Q 45 ; 46 ;Get food production facility for outpatient recurring meal, use 47 ;115.16.2 (outpatient location) which points to file 119.6 (nutrition 48 ;location) field 3 (tray service point) or field 4 (cafeteria service 49 ;point), which points to 119.72 (production facility) field 2. 50 I P["OP",D["RM" D 51 .S OPLOC=""_$P(NODE,U,3)_","_"",TRSVP=$$GET1^DIQ(119.6,OPLOC,3,"I") 52 .D GETDIV 53 .Q 54 ; 55 ;Get food production facility for outpatient tube feeding, use 56 ;115.16.2 (outpatient location) then use 119.6 nutrition location 57 ;which points to 119.72 field 2. 58 I P["OP",D["TF" D 59 .S OPLOC=""_$P(^TMP($J,"FH",DATE,FHDFN,NUMBER,"RM"),U,3)_","_"" 60 .S TRSVP=$$GET1^DIQ(119.6,OPLOC,3,"I") 61 .;Get delivery division 62 .D GETDIV 63 .Q 64 ; 65 ;Get food production facility for special meals, use 115.17.2 66 ;location field 2 which is a pointer to 119.6 (nutrition location) 67 ;which points to 119.72 via field 2 (tray service point) which points 68 ;to file 119.71 (production facility) field 2. 69 I P["OP",D["SM" D 70 .S OPLOC=""_$P(NODE,U,3)_","_"" 71 .S TRSVP=$$GET1^DIQ(119.6,OPLOC,3,"I") 72 .;Get delivery division 73 .D GETDIV 74 .Q 75 ; 76 ;Get food production facility for outpatient guest meals, use 77 ;115.18.4 (outpatient location) then use 119.6 nutrition location 78 ;which points to 119.72 (production facility) field 2. 79 I P["OP",D["GM" D 80 .S OPLOC=""_$P(NODE,U,5)_","_"",TRSVP=$$GET1^DIQ(119.6,OPLOC,3,"I") 81 .S ECXFPF=$$GET1^DIQ(119.72,""_TRSVP_","_"",2,"I") 82 .;Get delivery division 83 .D GETDIV 84 .Q 85 ; 86 ;Get delivery location type for patients; with inpatients the type of 87 ;service needs to be pulled from the admission node, with outpatients 88 ;the type of service needs to be pulled from different nodes and use 89 ;field 101 of Nutrition Location file (#119.6). Delivery location 90 ;types only set for the following meals: 91 ; Inpatient with a production diet 92 ; Outpatient with a recurring meal 93 ; Outpatient with a special meal 94 ; Outpatient with a guest meal 95 ; all other meals are null 96 I P="INP",D="PD" D 97 .S ECXDLT=$P($G(NODE),U,8) 98 I P="OP",((D="RM")!(D="SM")) D 99 .S ECXDLT=$E($$GET1^DIQ(119.6,""_$P(NODE,U,3)_","_"",101,"E"),1) 100 I P="OP",D="GM" D 101 .S ECXDLT=$E($$GET1^DIQ(119.6,""_$P(NODE,U,5)_","_"",101,"E"),1) 102 ; 103 ;Delivery feeder location 104 I ECXDLT="C" S ECXDFL=$P(NODE,U,8) D 105 .S ECXDFL=$E($$GET1^DIQ(119.72,ECXDFL,2,"E"),1,10) 106 I (ECXDLT["T")!(ECXDLT["D") D 107 .S MASWARD=$O(^FH(119.6,$S(WARD:+WARD,+OPLOC:+OPLOC,1:""),"W","B",0)) 108 .S ECXDFL=$$GET1^DIQ(42,+MASWARD,44,"I") 109 Q 1 110 ; 111 GETDIV ;Get divisions and food production facility 112 ;Init variables 113 N IEN,SIEN 114 S (ECXFDD,ECXFPF,ECXFPD)="" 115 S IEN=$$GET1^DIQ(119.72,+TRSVP,2,"I") 116 Q:'IEN 117 ;Get delivery division 118 S SIEN=""_+TRSVP_";FH(119.72," 119 S ECXFDD=$O(^ECX(728.46,"B",SIEN,ECXFDD)) 120 S ECXFDD=""_$$GET1^DIQ(728.46,ECXFDD,1,"I")_","_"" 121 S ECXFDD=$$GET1^DIQ(4,ECXFDD,99,"E") 122 ;Get production division and food production facility 123 S IEN=""_IEN_";FH(119.71," 124 S ECXFPF=$O(^ECX(728.46,"B",IEN,ECXFPF)) 125 S ECXFPD=""_$$GET1^DIQ(728.46,ECXFPF,1,"I")_","_"" 126 S ECXFPD=$$GET1^DIQ(4,ECXFPD,99,"E") 127 S ECXFPF=$E($$GET1^DIQ(728.46,ECXFPF,.01,"E"),1,10) 128 Q
Note:
See TracChangeset
for help on using the changeset viewer.
