Changeset 623 for WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX

Timestamp:

Dec 4, 2009, 12:11:15 AM (15 years ago)

Author:

George Lilly

Message:

revised back to 6/30/08 version

Location:

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX

Files:

• 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)

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX802.m

@@ -1 @@
-ECX802 ; DRIVER FOR COMPILED XREFS FOR FILE #727.802 ; 12/13/08
+ECX802 ; DRIVER FOR COMPILED XREFS FOR FILE #727.802 ; 12/27/07
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX8021.m

@@ -1 @@
-ECX8021 ; COMPILED XREF FOR FILE #727.802 ; 12/13/08
+ECX8021 ; COMPILED XREF FOR FILE #727.802 ; 12/27/07
  ; 
  S DIKZK=2

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX8022.m

@@ -1 @@
-ECX8022 ; COMPILED XREF FOR FILE #727.802 ; 12/13/08
+ECX8022 ; COMPILED XREF FOR FILE #727.802 ; 12/27/07
  ; 
  S DIKZK=1

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX808.m

@@ -1 @@
-ECX808 ; DRIVER FOR COMPILED XREFS FOR FILE #727.808 ; 12/13/08
+ECX808 ; DRIVER FOR COMPILED XREFS FOR FILE #727.808 ; 12/27/07
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX8081.m

@@ -1 @@
-ECX8081 ; COMPILED XREF FOR FILE #727.808 ; 12/13/08
+ECX8081 ; COMPILED XREF FOR FILE #727.808 ; 12/27/07
  ; 
  S DIKZK=2

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX8082.m

@@ -1 @@
-ECX8082 ; COMPILED XREF FOR FILE #727.808 ; 12/13/08
+ECX8082 ; COMPILED XREF FOR FILE #727.808 ; 12/27/07
  ; 
  S DIKZK=1

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX809.m

@@ -1 @@
-ECX809 ; DRIVER FOR COMPILED XREFS FOR FILE #727.809 ; 12/13/08
+ECX809 ; DRIVER FOR COMPILED XREFS FOR FILE #727.809 ; 12/27/07
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX8091.m

@@ -1 @@
-ECX8091 ; COMPILED XREF FOR FILE #727.809 ; 12/13/08
+ECX8091 ; COMPILED XREF FOR FILE #727.809 ; 12/27/07
  ; 
  S DIKZK=2

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX8092.m

@@ -1 @@
-ECX8092 ; COMPILED XREF FOR FILE #727.809 ; 12/13/08
+ECX8092 ; COMPILED XREF FOR FILE #727.809 ; 12/27/07
  ; 
  S DIKZK=1

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX810.m

@@ -1 @@
-ECX810 ; DRIVER FOR COMPILED XREFS FOR FILE #727.81 ; 12/13/08
+ECX810 ; DRIVER FOR COMPILED XREFS FOR FILE #727.81 ; 12/27/07
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX8101.m

@@ -1 @@
-ECX8101 ; COMPILED XREF FOR FILE #727.81 ; 12/13/08
+ECX8101 ; COMPILED XREF FOR FILE #727.81 ; 12/27/07
  ; 
  S DIKZK=2

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX8102.m

@@ -1 @@
-ECX8102 ; COMPILED XREF FOR FILE #727.81 ; 12/13/08
+ECX8102 ; COMPILED XREF FOR FILE #727.81 ; 12/27/07
  ; 
  S DIKZK=1

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX811.m

@@ -1 @@
-ECX811 ; DRIVER FOR COMPILED XREFS FOR FILE #727.811 ; 12/13/08
+ECX811 ; DRIVER FOR COMPILED XREFS FOR FILE #727.811 ; 12/25/06
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX8111.m

@@ -1 @@
-ECX8111 ; COMPILED XREF FOR FILE #727.811 ; 12/13/08
+ECX8111 ; COMPILED XREF FOR FILE #727.811 ; 12/25/06
  ; 
  S DIKZK=2

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX8112.m

@@ -1 @@
-ECX8112 ; COMPILED XREF FOR FILE #727.811 ; 12/13/08
+ECX8112 ; COMPILED XREF FOR FILE #727.811 ; 12/25/06
  ; 
  S DIKZK=1

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX813.m

@@ -1 @@
-ECX813 ; DRIVER FOR COMPILED XREFS FOR FILE #727.813 ; 12/13/08
+ECX813 ; DRIVER FOR COMPILED XREFS FOR FILE #727.813 ; 12/27/07
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX8131.m

@@ -1 @@
-ECX8131 ; COMPILED XREF FOR FILE #727.813 ; 12/13/08
+ECX8131 ; COMPILED XREF FOR FILE #727.813 ; 12/27/07
  ; 
  S DIKZK=2

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX8132.m

@@ -1 @@
-ECX8132 ; COMPILED XREF FOR FILE #727.813 ; 12/13/08
+ECX8132 ; COMPILED XREF FOR FILE #727.813 ; 12/27/07
  ; 
  S DIKZK=1

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX814.m

@@ -1 @@
-ECX814 ; DRIVER FOR COMPILED XREFS FOR FILE #727.814 ; 12/13/08
+ECX814 ; DRIVER FOR COMPILED XREFS FOR FILE #727.814 ; 12/25/06
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX8141.m

@@ -1 @@
-ECX8141 ; COMPILED XREF FOR FILE #727.814 ; 12/13/08
+ECX8141 ; COMPILED XREF FOR FILE #727.814 ; 12/25/06
  ; 
  S DIKZK=2

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX8142.m

@@ -1 @@
-ECX8142 ; COMPILED XREF FOR FILE #727.814 ; 12/13/08
+ECX8142 ; COMPILED XREF FOR FILE #727.814 ; 12/25/06
  ; 
  S DIKZK=1

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX815.m

@@ -1 @@
-ECX815 ; DRIVER FOR COMPILED XREFS FOR FILE #727.815 ; 12/13/08
+ECX815 ; DRIVER FOR COMPILED XREFS FOR FILE #727.815 ; 12/25/06
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX8151.m

@@ -1 @@
-ECX8151 ; COMPILED XREF FOR FILE #727.815 ; 12/13/08
+ECX8151 ; COMPILED XREF FOR FILE #727.815 ; 12/25/06
  ; 
  S DIKZK=2

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX8152.m

@@ -1 @@
-ECX8152 ; COMPILED XREF FOR FILE #727.815 ; 12/13/08
+ECX8152 ; COMPILED XREF FOR FILE #727.815 ; 12/25/06
  ; 
  S DIKZK=1

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX817.m

@@ -1 @@
-ECX817 ; DRIVER FOR COMPILED XREFS FOR FILE #727.817 ; 12/13/08
+ECX817 ; DRIVER FOR COMPILED XREFS FOR FILE #727.817 ; 12/27/07
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX8171.m

@@ -1 @@
-ECX8171 ; COMPILED XREF FOR FILE #727.817 ; 12/13/08
+ECX8171 ; COMPILED XREF FOR FILE #727.817 ; 12/27/07
  ; 
  S DIKZK=2

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX8172.m

@@ -1 @@
-ECX8172 ; COMPILED XREF FOR FILE #727.817 ; 12/13/08
+ECX8172 ; COMPILED XREF FOR FILE #727.817 ; 12/27/07
  ; 
  S DIKZK=1

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX819.m

@@ -1 @@
-ECX819 ; DRIVER FOR COMPILED XREFS FOR FILE #727.819 ; 12/13/08
+ECX819 ; DRIVER FOR COMPILED XREFS FOR FILE #727.819 ; 12/27/07
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX8191.m

@@ -1 @@
-ECX8191 ; COMPILED XREF FOR FILE #727.819 ; 12/13/08
+ECX8191 ; COMPILED XREF FOR FILE #727.819 ; 12/27/07
  ; 
  S DIKZK=2

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX8192.m

@@ -1 @@
-ECX8192 ; COMPILED XREF FOR FILE #727.819 ; 12/13/08
+ECX8192 ; COMPILED XREF FOR FILE #727.819 ; 12/27/07
  ; 
  S DIKZK=1

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX824.m

@@ -1 @@
-ECX824 ; DRIVER FOR COMPILED XREFS FOR FILE #727.824 ; 12/13/08
+ECX824 ; DRIVER FOR COMPILED XREFS FOR FILE #727.824 ; 12/27/07
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX8241.m

@@ -1 @@
-ECX8241 ; COMPILED XREF FOR FILE #727.824 ; 12/13/08
+ECX8241 ; COMPILED XREF FOR FILE #727.824 ; 12/27/07
  ; 
  S DIKZK=2

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX8242.m

@@ -1 @@
-ECX8242 ; COMPILED XREF FOR FILE #727.824 ; 12/13/08
+ECX8242 ; COMPILED XREF FOR FILE #727.824 ; 12/27/07
  ; 
  S DIKZK=1

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX825.m

@@ -1 @@
-ECX825 ; DRIVER FOR COMPILED XREFS FOR FILE #727.825 ; 12/13/08
+ECX825 ; DRIVER FOR COMPILED XREFS FOR FILE #727.825 ; 12/25/06
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX8251.m

@@ -1 @@
-ECX8251 ; COMPILED XREF FOR FILE #727.825 ; 12/13/08
+ECX8251 ; COMPILED XREF FOR FILE #727.825 ; 12/25/06
  ; 
  S DIKZK=2

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX8252.m

@@ -1 @@
-ECX8252 ; COMPILED XREF FOR FILE #727.825 ; 12/13/08
+ECX8252 ; COMPILED XREF FOR FILE #727.825 ; 12/25/06
  ; 
  S DIKZK=1

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX826.m

@@ -1 @@
-ECX826 ; DRIVER FOR COMPILED XREFS FOR FILE #727.826 ; 12/13/08
+ECX826 ; DRIVER FOR COMPILED XREFS FOR FILE #727.826 ; 12/25/06
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX8261.m

@@ -1 @@
-ECX8261 ; COMPILED XREF FOR FILE #727.826 ; 12/13/08
+ECX8261 ; COMPILED XREF FOR FILE #727.826 ; 12/25/06
  ; 
  S DIKZK=2

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX8262.m

@@ -1 @@
-ECX8262 ; COMPILED XREF FOR FILE #727.826 ; 12/13/08
+ECX8262 ; COMPILED XREF FOR FILE #727.826 ; 12/25/06
  ; 
  S DIKZK=1

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX827.m

@@ -1 @@
-ECX827 ; DRIVER FOR COMPILED XREFS FOR FILE #727.827 ; 12/13/08
+ECX827 ; DRIVER FOR COMPILED XREFS FOR FILE #727.827 ; 12/27/07
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX8271.m

@@ -1 @@
-ECX8271 ; COMPILED XREF FOR FILE #727.827 ; 12/13/08
+ECX8271 ; COMPILED XREF FOR FILE #727.827 ; 12/27/07
  ; 
  S DIKZK=2

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECX8272.m

@@ -1 @@
-ECX8272 ; COMPILED XREF FOR FILE #727.827 ; 12/13/08
+ECX8272 ; COMPILED XREF FOR FILE #727.827 ; 12/27/07
  ; 
  S DIKZK=1

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXADM.m

@@ -1 @@
-ECXADM  ;ALB/JAP,BIR/DMA,CML,PTD-Admissions Extract ; 10/15/07 12:14pm
-        ;;3.0;DSS EXTRACTS;**1,4,11,8,13,24,33,39,46,71,84,92,107,105**;Dec 22, 1997;Build 70
-BEG     ;entry point from option
-        D SETUP I ECFILE="" Q
-        D ^ECXTRAC,^ECXKILL
-        Q
-        ;
-START   ; start package specific extract
-        S QFLG=0
-        S ECED=ECED+.3,ECD=ECSD1
-        F  S ECD=$O(^DGPM("ATT1",ECD)),ECDA=0 Q:('ECD)!(ECD>ECED)  D
-        .F  S ECDA=$O(^DGPM("ATT1",ECD,ECDA)) Q:ECDA=""  D
-        ..I $D(^DGPM(ECDA,0)) D
-        ...S EC=^DGPM(ECDA,0),ECXDFN=$P(EC,U,3) D GET
-        Q
-        ;
-GET     ;gather extract data
-        N ADM,W,X,ECXNPRFI,ECXATTPC,ECXPRVPC,ECXEST
-        ;patient demographics
-        S ECXERR=0 D PAT(ECXDFN,ECD,.ECXERR)
-        Q:ECXERR
-        I $$ENROLLM^ECXUTL2(ECXDFN)
-        S ECXFAC=$P($G(^DIC(42,+$P(EC,U,6),0)),U,11)
-        S ECXPDIV=$$GETDIV^ECXDEPT(ECXFAC)  ;Get production division
-        ;admission data
-        S ELGA=$P($G(^DIC(8,+$P(EC,U,20),0)),U,9)
-        I ELGA S ELGA=$$ELIG^ECXUTL3(ELGA,ECXSVC)
-        S (ECDRG,ECDIA,ECXSADM)="",ECPTF=+$P(EC,U,16) I ECPTF,$D(^DGPT(ECPTF,"M")) D PTF
-        ;get encounter classification
-        S (ECXAO,ECXECE,ECXIR,ECXMIL,ECXHNC)="",ECXVISIT=$P(EC,U,27)
-        I ECXVISIT'="" D
-        .D VISIT^ECXSCX1(ECXDFN,ECXVISIT,.ECXVIST,.ECXERR) I ECXERR K ECXERR Q
-        .S ECXAO=$G(ECXVIST("AO")),ECXIR=$G(ECXVIST("IR"))
-        .S ECXMIL=$G(ECXVIST("MST")),ECXHNC=$G(ECXVIST("HNC"))
-        .S ECXECE=$G(ECXVIST("PGE"))
-        ;use movement record date & time
-        S ADM=$$INP^ECXUTL2(ECXDFN,ECD)
-        S ECXA=$P(ADM,U),ECXMN=$P(ADM,U,2),ECXSPC=$P(ADM,U,3)
-        S (ECXADMDT,ECXDATE)=$P(ADM,U,4)
-        ;if movement# doesn't match cross-ref ien, then quit
-        Q:ECXMN'=ECDA
-        S ECTM=$$ECXTIME^ECXUTL(ECXDATE)
-        S ECXDATE=$$ECXDATE^ECXUTL(ECXDATE,ECXYM)
-        S W=$P(ADM,U,9)
-        S ECXWRD=$P(W,";",1),ECXFAC=$P(W,";",2),ECXDSSD=$P(W,";",3)
-        S ECXPRV=$P(ADM,U,7),ECXPRNPI="",ECXATT=$P(ADM,U,8),ECXATNPI=""
-        S ECXDOM=$P(ADM,U,10),ECXATTPC=$P(ADM,U,12),ECXPRVPC=$P(ADM,U,11)
-        N ECXUSRTN
-        S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",$E(ECXATT,2,$L(ECXATT)),ECD)
-        S:+ECXUSRTN'>0 ECXUSRTN=""
-        S ECATTNPI=$P(ECXUSRTN,U)
-        S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",$E(ECXPRV,2,$L(ECXPRV)),ECD)
-        S:+ECXUSRTN'>0 ECXUSRTN=""
-        S ECPWNPI=$P(ECXUSRTN,U)
-        ;
-        ;- Observation patient indicator (YES/NO)
-        S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXSPC)
-        ;
-        ;- Patient Type
-        S ECXPTYPE=$$TYPE^ECXUTL5(ECXDFN)
-        ;
-        ;- If null encounter number, don't file record
-        S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,,ECXSPC,ECXOBS,ECHEAD,,)
-        D:ECXENC'="" FILE
-        Q
-        ;
-PAT(ECXDFN,ECXDATE,ECXERR)      ;get patient demographic data
-        N OK,X
-        K ECXPAT
-        S ECXDATE=$P(ECXDATE,".")
-        S OK=$$PAT^ECXUTL3(ECXDFN,ECXDATE,"1;2;3;4;5",.ECXPAT)
-        I 'OK S ECXERR=1 K ECXPAT Q
-        S ECXSSN=ECXPAT("SSN")
-        S ECXPNM=ECXPAT("NAME")
-        S ECXMPI=ECXPAT("MPI")
-        S ECXSEX=ECXPAT("SEX")
-        S ECXDOB=ECXPAT("DOB")
-        S ECXELIG=ECXPAT("ELIG")
-        S ECXVET=ECXPAT("VET")
-        S ECXVNS=ECXPAT("VIETNAM")
-        S ECXPOS=ECXPAT("POS")
-        S ECXMNS=ECXPAT("MEANS")
-        S ECXRACE=ECXPAT("RACE")
-        S ECXRELG=ECXPAT("RELIGION")
-        S ECXEMP=ECXPAT("EMPLOY")
-        S ECXMAR=ECXPAT("MARITAL")
-        S ECXPST=ECXPAT("POW STAT")
-        S ECXPLOC=ECXPAT("POW LOC")
-        S ECXRST=ECXPAT("IR STAT")
-        S ECXAST=ECXPAT("AO STAT")
-        S ECXMST=ECXPAT("MST STAT")
-        S ECXSTATE=ECXPAT("STATE")
-        S ECXCNTY=ECXPAT("COUNTY")
-        S ECXZIP=ECXPAT("ZIP")
-        S ECXENRL=ECXPAT("ENROLL LOC")
-        S ECXSVC=ECXPAT("SC%")
-        S ECXPHI=ECXPAT("PHI")
-        S ECXHI=+$$INSUR^IBBAPI(ECXDFN,ECXDATE)
-        S ECXEST=ECXPAT("EC STAT")
-        ;
-        ;-OEF/OIF Data
-        S ECXOEF=ECXPAT("ECXOEF")
-        S ECXOEFDT=ECXPAT("ECXOEFDT")
-        ;
-        ;- Agent Orange location
-        S ECXAOL=ECXPAT("AOL")
-        ;
-        ; - Head and Neck Cancer Indicator
-        S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN)
-        ; - Race and Ethnicity
-        S ECXETH=ECXPAT("ETHNIC")
-        S ECXRC1=ECXPAT("RACE1")
-        ;
-        ;get primary care data
-        S X=$$PRIMARY^ECXUTL2(ECXDFN,ECXDATE)
-        S ECPTTM=$P(X,U),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4)
-        S ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7)
-        ;get combat veteran data
-        I $$CVEDT^ECXUTL5(ECXDFN,ECD)
-        ;get national patient record flag if exist
-        D NPRF^ECXUTL5
-        ;get emergency response indicator (FEMA)
-        S ECXERI=ECXPAT("ERI")
-        Q
-        ;
-PTF     ; get admitting DRG, diagnosis, source of admission from PTF
-        ;use number for DRG and .01 for diagnosis
-        N EC,EC1,ECX
-        S EC=1 I $D(^DGPT(ECPTF,"M",2,0)) S EC=2
-        S EC1=+$P(^DGPT(ECPTF,"M",EC,0),U,5)
-        S ECDRG=$P($G(^DGPT(ECPTF,"M",EC,"P")),U)
-        S ECDIA=$P($G(^ICD9(EC1,0)),U)
-        S ECX=+$P($G(^DGPT(ECPTF,101)),U),ECXSADM=$P($G(^DIC(45.1,ECX,0)),U,11)
-        Q
-        ;
-FILE    ;file the extract record
-        ;node0
-        ;facility^dfn^ssn^name^in/out^day^primary care team^sex^dob^
-        ;religion^employment status^health ins^state^county^zip^
-        ;eligibility^vet^vietnam^agent orange^radiation^pow^
-        ;period of service^means test^marital status^
-        ;ward^treating specialty^attending physician^mov #^DRG^diagnosis^
-        ;time^primary care provider^race^primary ward provider
-        ;node1
-        ;mpi^dss dept^attending npi^pc provider npi^ward provider npi^
-        ;admission elig^mst status^^sharing payor^
-        ;sharing insurance^enrollment location^
-        ;pc prov person class^assoc pc provider^assoc pc prov person class^
-        ;assoc pc prov npi^dom^enrollment cat^enrollment stat^enrollment
-        ;priority^purple heart ind.^obs pat ind^encounter num^agent orange
-        ;loc^production div^pow loc^source of admission^head & neck canc. ind
-        ;^ethnicity^race1^enrollment priority_sub group^user enrollee^patient
-        ;type^combat vet elig^combat vet elig end date^enc cv eligible^
-        ;national patient record flag ECXNPRFI^att phy person class ECXATTPC
-        ;^primary ward provider person class ECXPRVPC^environ contamin ECXEST
-        ;^emergency response indicator(FEMA) ECXERI^agent orange indic ECXAO
-        ;^environ contam ECXECE^encoun head/neck ECXHNC^encoun MST ECXMIL^rad
-        ;encoun ECXIR^ OEF/OIF ECXOEF^ OEF/OIF return date ECXOEFDT
-        ;^associate pc provider npi ECASNPI^attending physician npi ECATNPI^
-        ;primary care provider npi ECPTNPI^primary ward provider npi ECPWNPI
-        ;
-        ;Convert specialty to PTF Code
-        ;
-        N ECXDATA
-        S ECXDATA=$$TSDATA^DGACT(42.4,+ECXSPC,.ECXDATA)
-        S ECXSPC=$G(ECXDATA(7))
-        ;
-        N DA,DIK
-        S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1
-        S ECODE=EC7_U_EC23_U_ECXFAC_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U_ECXDATE_U
-        S ECODE=ECODE_ECPTTM_U_ECXSEX_U_ECXDOB_U_ECXRELG_U
-        S ECODE=ECODE_ECXEMP_U_ECXHI_U_ECXSTATE_U_ECXCNTY_U_ECXZIP_U
-        S ECODE=ECODE_ECXELIG_U_ECXVET_U_ECXVNS_U_ECXAST_U_ECXRST_U_ECXPST_U
-        S ECODE=ECODE_ECXPOS_U_ECXMNS_U_ECXMAR_U
-        S ECODE=ECODE_ECXWRD_U_ECXSPC_U_ECXATT_U_ECDA_U_ECDRG_U_ECDIA_U
-        S ECODE=ECODE_ECTM_U_ECPTPR_U_ECXRACE_U_ECXPRV_U
-        S ECODE1=ECXMPI_U_ECXDSSD_U_""_U_""_U_""_U_ELGA_U
-        S ECODE1=ECODE1_ECXMST_U_U_U_U_ECXENRL_U_ECCLAS_U
-        S ECODE1=ECODE1_ECASPR_U_ECCLAS2_U_U_ECXDOM_U_ECXCAT_U
-        S ECODE1=ECODE1_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXPHI_U_ECXOBS_U_ECXENC_U_ECXAOL_U
-        S ECODE1=ECODE1_ECXPDIV_U_ECXPLOC_U_ECXSADM_U_ECXHNCI_U_ECXETH_U
-        S ECODE1=ECODE1_ECXRC1
-        I ECXLOGIC>2004 S ECODE1=ECODE1_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXNPRFI
-        I ECXLOGIC>2005 S ECODE1=ECODE1_U_ECXATTPC_U_ECXPRVPC_U_ECXEST
-        I ECXLOGIC>2006 S ECODE1=ECODE1_U_ECXERI_U_ECXAO_U_ECXECE_U_ECXHNC_U_ECXMIL_U_ECXIR_U
-        I ECXLOGIC>2007 S ECODE2=ECXOEF_U_ECXOEFDT_U_ECASNPI_U_ECATTNPI_U_ECPTNPI_U_ECPWNPI
-        S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,^ECX(ECFILE,EC7,2)=$G(ECODE2)
-        S ECRN=ECRN+1
-        S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA
-        Q
-        ;
-SETUP   ;Set required input for ECXTRAC.
-        S ECHEAD="ADM"
-        D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
-        Q
-        ;
-LOCAL   ; to extract nightly for local use not to be transmitted to TSI
-        ; should be queued with a 1D frequency
-        D SETUP,^ECXTLOCL,^ECXKILL Q
-        ;
-QUE     ; entry point for the background requeuing handled by ECXTAUTO
-        D SETUP,QUE^ECXTAUTO,^ECXKILL Q
-        ;
+ECXADM ;ALB/JAP,BIR/DMA,CML,PTD-Admissions Extract ; 04/12/2007
+ ;;3.0;DSS EXTRACTS;**1,4,11,8,13,24,33,39,46,71,84,92,107**;Dec 22, 1997;Build 9
+BEG ;entry point from option
+ D SETUP I ECFILE="" Q
+ D ^ECXTRAC,^ECXKILL
+ Q
+ ;
+START ; start package specific extract
+ S QFLG=0
+ S ECED=ECED+.3,ECD=ECSD1
+ F  S ECD=$O(^DGPM("ATT1",ECD)),ECDA=0 Q:('ECD)!(ECD>ECED)  D
+ .F  S ECDA=$O(^DGPM("ATT1",ECD,ECDA)) Q:ECDA=""  D
+ ..I $D(^DGPM(ECDA,0)) D
+ ...S EC=^DGPM(ECDA,0),ECXDFN=$P(EC,U,3) D GET
+ Q
+ ;
+GET ;gather extract data
+ N ADM,W,X,ECXNPRFI,ECXATTPC,ECXPRVPC,ECXEST
+ ;patient demographics
+ S ECXERR=0 D PAT(ECXDFN,ECD,.ECXERR)
+ Q:ECXERR
+ I $$ENROLLM^ECXUTL2(ECXDFN)
+ S ECXFAC=$P($G(^DIC(42,+$P(EC,U,6),0)),U,11)
+ S ECXPDIV=$$GETDIV^ECXDEPT(ECXFAC)  ;Get production division
+ ;admission data
+ S ELGA=$P($G(^DIC(8,+$P(EC,U,20),0)),U,9)
+ I ELGA S ELGA=$$ELIG^ECXUTL3(ELGA,ECXSVC)
+ S (ECDRG,ECDIA,ECXSADM)="",ECPTF=+$P(EC,U,16) I ECPTF,$D(^DGPT(ECPTF,"M")) D PTF
+ ;get encounter classification
+ S (ECXAO,ECXECE,ECXIR,ECXMIL,ECXHNC)="",ECXVISIT=$P(EC,U,27)
+ I ECXVISIT'="" D
+ .D VISIT^ECXSCX1(ECXDFN,ECXVISIT,.ECXVIST,.ECXERR) I ECXERR K ECXERR Q
+ .S ECXAO=$G(ECXVIST("AO")),ECXIR=$G(ECXVIST("IR"))
+ .S ECXMIL=$G(ECXVIST("MST")),ECXHNC=$G(ECXVIST("HNC"))
+ .S ECXECE=$G(ECXVIST("PGE"))
+ ;use movement record date & time
+ S ADM=$$INP^ECXUTL2(ECXDFN,ECD)
+ S ECXA=$P(ADM,U),ECXMN=$P(ADM,U,2),ECXSPC=$P(ADM,U,3)
+ S (ECXADMDT,ECXDATE)=$P(ADM,U,4)
+ ;if movement# doesn't match cross-ref ien, then quit
+ Q:ECXMN'=ECDA
+ S ECTM=$$ECXTIME^ECXUTL(ECXDATE)
+ S ECXDATE=$$ECXDATE^ECXUTL(ECXDATE,ECXYM)
+ S W=$P(ADM,U,9)
+ S ECXWRD=$P(W,";",1),ECXFAC=$P(W,";",2),ECXDSSD=$P(W,";",3)
+ S ECXPRV=$P(ADM,U,7),ECXPRNPI="",ECXATT=$P(ADM,U,8),ECXATNPI=""
+ S ECXDOM=$P(ADM,U,10),ECXATTPC=$P(ADM,U,12),ECXPRVPC=$P(ADM,U,11)
+ ;
+ ;- Observation patient indicator (YES/NO)
+ S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXSPC)
+ ;
+ ;- Patient Type
+ S ECXPTYPE=$$TYPE^ECXUTL5(ECXDFN)
+ ;
+ ;- If null encounter number, don't file record
+ S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,,ECXSPC,ECXOBS,ECHEAD,,)
+ D:ECXENC'="" FILE
+ Q
+ ;
+PAT(ECXDFN,ECXDATE,ECXERR) ;get patient demographic data
+ N OK,X
+ K ECXPAT
+ S ECXDATE=$P(ECXDATE,".")
+ S OK=$$PAT^ECXUTL3(ECXDFN,ECXDATE,"1;2;3;4;5",.ECXPAT)
+ I 'OK S ECXERR=1 K ECXPAT Q
+ S ECXSSN=ECXPAT("SSN")
+ S ECXPNM=ECXPAT("NAME")
+ S ECXMPI=ECXPAT("MPI")
+ S ECXSEX=ECXPAT("SEX")
+ S ECXDOB=ECXPAT("DOB")
+ S ECXELIG=ECXPAT("ELIG")
+ S ECXVET=ECXPAT("VET")
+ S ECXVNS=ECXPAT("VIETNAM")
+ S ECXPOS=ECXPAT("POS")
+ S ECXMNS=ECXPAT("MEANS")
+ S ECXRACE=ECXPAT("RACE")
+ S ECXRELG=ECXPAT("RELIGION")
+ S ECXEMP=ECXPAT("EMPLOY")
+ S ECXMAR=ECXPAT("MARITAL")
+ S ECXPST=ECXPAT("POW STAT")
+ S ECXPLOC=ECXPAT("POW LOC")
+ S ECXRST=ECXPAT("IR STAT")
+ S ECXAST=ECXPAT("AO STAT")
+ S ECXMST=ECXPAT("MST STAT")
+ S ECXSTATE=ECXPAT("STATE")
+ S ECXCNTY=ECXPAT("COUNTY")
+ S ECXZIP=ECXPAT("ZIP")
+ S ECXENRL=ECXPAT("ENROLL LOC")
+ S ECXSVC=ECXPAT("SC%")
+ S ECXPHI=ECXPAT("PHI")
+ S ECXHI=+$$INSUR^IBBAPI(ECXDFN,ECXDATE)
+ S ECXEST=ECXPAT("EC STAT")
+ ;
+ ;- Agent Orange location
+ S ECXAOL=ECXPAT("AOL")
+ ;
+ ; - Head and Neck Cancer Indicator
+ S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN)
+ ; - Race and Ethnicity
+ S ECXETH=ECXPAT("ETHNIC")
+ S ECXRC1=ECXPAT("RACE1")
+ ;
+ ;get primary care data
+ S X=$$PRIMARY^ECXUTL2(ECXDFN,ECXDATE)
+ S ECPTTM=$P(X,U),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4)
+ S ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7)
+ ;get combat veteran data
+ I $$CVEDT^ECXUTL5(ECXDFN,ECD)
+ ;get national patient record flag if exist
+ D NPRF^ECXUTL5
+ ;get emergency response indicator (FEMA)
+ S ECXERI=ECXPAT("ERI")
+ Q
+ ;
+PTF ; get admitting DRG, diagnosis, source of admission from PTF
+ ;use number for DRG and .01 for diagnosis
+ N EC,EC1,ECX
+ S EC=1 I $D(^DGPT(ECPTF,"M",2,0)) S EC=2
+ S EC1=+$P(^DGPT(ECPTF,"M",EC,0),U,5)
+ S ECDRG=$P($G(^DGPT(ECPTF,"M",EC,"P")),U)
+ S ECDIA=$P($G(^ICD9(EC1,0)),U)
+ S ECX=+$P($G(^DGPT(ECPTF,101)),U),ECXSADM=$P($G(^DIC(45.1,ECX,0)),U,11)
+ Q
+ ;
+FILE ;file the extract record
+ ;node0
+ ;facility^dfn^ssn^name^in/out^day^primary care team^sex^dob^
+ ;religion^employment status^health ins^state^county^zip^
+ ;eligibility^vet^vietnam^agent orange^radiation^pow^
+ ;period of service^means test^marital status^
+ ;ward^treating specialty^attending physician^mov #^DRG^diagnosis^
+ ;time^primary care provider^race^primary ward provider
+ ;node1
+ ;mpi^dss dept^attending npi^pc provider npi^ward provider npi^
+ ;admission elig^mst status^^sharing payor^
+ ;sharing insurance^enrollment location^
+ ;pc prov person class^assoc pc provider^assoc pc prov person class^
+ ;assoc pc prov npi^dom^enrollment cat^enrollment stat^enrollment
+ ;priority^purple heart ind.^obs pat ind^encounter num^agent orange
+ ;loc^production div^pow loc^source of admission^head & neck canc. ind
+ ;^ethnicity^race1^enrollment priority_sub group^user enrollee^patient
+ ;type^combat vet elig^combat vet elig end date^enc cv eligible^
+ ;national patient record flag ECXNPRFI^att phy person class ECXATTPC
+ ;^primary ward provider person class ECXPRVPC^environ contamin ECXEST
+ ;^emergency response indicator(FEMA) ECXERI^agent orange indic ECXAO
+ ;^environ contam ECXECE^encoun head/neck ECXHNC^encoun MST ECXMIL^rad
+ ;encoun ECXIR
+ ;
+ ;Convert specialty to PTF Code
+ ;
+ N ECXDATA
+ S ECXDATA=$$TSDATA^DGACT(42.4,+ECXSPC,.ECXDATA)
+ S ECXSPC=$G(ECXDATA(7))
+ ;
+ N DA,DIK
+ S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1
+ S ECODE=EC7_U_EC23_U_ECXFAC_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U_ECXDATE_U
+ S ECODE=ECODE_ECPTTM_U_ECXSEX_U_ECXDOB_U_ECXRELG_U
+ S ECODE=ECODE_ECXEMP_U_ECXHI_U_ECXSTATE_U_ECXCNTY_U_ECXZIP_U
+ S ECODE=ECODE_ECXELIG_U_ECXVET_U_ECXVNS_U_ECXAST_U_ECXRST_U_ECXPST_U
+ S ECODE=ECODE_ECXPOS_U_ECXMNS_U_ECXMAR_U
+ S ECODE=ECODE_ECXWRD_U_ECXSPC_U_ECXATT_U_ECDA_U_ECDRG_U_ECDIA_U
+ S ECODE=ECODE_ECTM_U_ECPTPR_U_ECXRACE_U_ECXPRV_U
+ S ECODE1=ECXMPI_U_ECXDSSD_U_ECXATNPI_U_ECPTNPI_U_ECXPRNPI_U_ELGA_U
+ S ECODE1=ECODE1_ECXMST_U_U_U_U_ECXENRL_U_ECCLAS_U
+ S ECODE1=ECODE1_ECASPR_U_ECCLAS2_U_ECASNPI_U_ECXDOM_U_ECXCAT_U
+ S ECODE1=ECODE1_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXPHI_U_ECXOBS_U_ECXENC_U_ECXAOL_U
+ S ECODE1=ECODE1_ECXPDIV_U_ECXPLOC_U_ECXSADM_U_ECXHNCI_U_ECXETH_U
+ S ECODE1=ECODE1_ECXRC1
+ I ECXLOGIC>2004 S ECODE1=ECODE1_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXNPRFI
+ I ECXLOGIC>2005 S ECODE1=ECODE1_U_ECXATTPC_U_ECXPRVPC_U_ECXEST
+ I ECXLOGIC>2006 S ECODE1=ECODE1_U_ECXERI_U_ECXAO_U_ECXECE_U_ECXHNC_U_ECXMIL_U_ECXIR
+ S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1
+ S ECRN=ECRN+1
+ S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA
+ Q
+ ;
+SETUP ;Set required input for ECXTRAC.
+ S ECHEAD="ADM"
+ D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
+ Q
+ ;
+LOCAL ; to extract nightly for local use not to be transmitted to TSI
+ ; should be queued with a 1D frequency
+ D SETUP,^ECXTLOCL,^ECXKILL Q
+ ;
+QUE ; entry point for the background requeuing handled by ECXTAUTO
+ D SETUP,QUE^ECXTAUTO,^ECXKILL Q
+ ;

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXAPHA2.m

@@ -1 @@
-ECXAPHA2        ;ALB/TMD-Pharmacy Extracts Unusual Volumes Report ; 10/18/07 2:10pm
-        ;;3.0;DSS EXTRACTS;**40,49,84,104,105**;Dec 22, 1997;Build 70
-        ;
-EN      ; entry point
-        N COUNT,ECUNIT,LINE,ECDFN,ECD,ECDRG,ECDAY,ECDFN,ECQTY,ECUNIT,ECCOST,ECDS
-        K ^TMP($J)
-        S (COUNT,ECDS)=0,ECUNIT=""
-        S ECD=ECSD1,ECED=ECED+.3
-        S LINE=$S(ECXOPT=1:"PRE",ECXOPT=2:"IVP",ECXOPT=3:"UDP",1:"EXIT")
-        D @LINE
-        Q
-        ;
-PRE     ; entry point for PRE data
-        N ECRFL,ECRX,ECREF,ECDATA,ECDATA1,ECPRC,IEN
-        K ^TMP($J,"ECXDSS")
-        ;call pharmacy api pso52ex
-        D EXTRACT^PSO52EX(ECD,ECED,"ECXDSS")
-        S ECREF="RF"
-        ;order thru fills and refills; refill values 0 thru 11
-        ;     Note:  refill 0 = original fill
-        F  S ECD=$O(^TMP($J,"ECXDSS","AL",ECD)),IEN=0 Q:'ECD  Q:ECD>ECED  Q:ECXERR  F  S IEN=$O(^(ECD,IEN)),ECRFL=""  Q:'IEN  Q:ECXERR  F  S ECRFL=$O(^(IEN,ECRFL)) Q:'ECRFL  Q:ECXERR  D PRE2
-        ;
-        ;order thru partial fills
-        S ECD=ECSD1,ECREF="P"
-        F  S ECD=$O(^TMP($J,"ECXDSS","AM",ECD)),IEN=0 Q:'ECD  Q:ECD>ECED  Q:ECXERR  F  S IEN=$O(^(ECD,IEN)),ECRFL=""  Q:'IEN  Q:ECXERR  F  S ECRFL=$O(^(IEN,ECRFL)) Q:'ECRFL  Q:ECXERR  D PRE2
-        K ^TMP($J,"ECXDSS")
-        Q
-        ;
-PRE2    ; get Prescription data
-        I (ECREF="RF")&(ECRFL) D
-        .S ECQTY=+^TMP($J,"ECXDSS",IEN,ECREF,ECRFL,1)
-        .S ECDS=+^TMP($J,"ECXDSS",IEN,ECREF,ECRFL,1.1)
-        .S ECPRC=^TMP($J,"ECXDSS",IEN,ECREF,ECRFL,1.2)
-        I (ECREF="RF")&('ECRFL) D
-        .S ECQTY=+^TMP($J,"ECXDSS",IEN,7)
-        .S ECDS=+^TMP($J,"ECXDSS",IEN,8)
-        .S ECPRC=+^TMP($J,"ECXDSS",IEN,17)
-        I ECREF="P" D
-        .S ECQTY=+^TMP($J,"ECXDSS",IEN,ECREF,ECRFL,.04)
-        .S ECDS=+^TMP($J,"ECXDSS",IEN,ECREF,ECRFL,.041)
-        .S ECPRC=+^TMP($J,"ECXDSS",IEN,ECREF,ECRFL,.042)
-        ;check to see if quantity>threshold
-        I ECQTY>ECTHLD D
-        .S ECDAY=ECD
-        .S ECDFN=$P(^TMP($J,"ECXDSS",IEN,2),U)
-        .S ECDRG=+$P(^TMP($J,"ECXDSS",IEN,6),U)
-        .S ECCOST=ECQTY*ECPRC
-        .D FILE Q:ECXERR
-        Q
-        ;
-IVP     ; entry point for IVP Data
-        N DFN,ON,DA,SA,ECCOUNT
-        F  S ECD=$O(^ECX(728.113,"A",ECD)),DFN=0 Q:'ECD  Q:ECD>ECED  Q:ECXERR  F  S DFN=$O(^ECX(728.113,"A",ECD,DFN)),ON=0  Q:'DFN  F  S ON=$O(^ECX(728.113,"A",ECD,DFN,ON)),DA=0 Q:'ON  K ^TMP($J,"A"),^("S") D  Q:ECXERR
-        .F  S DA=$O(^ECX(728.113,"A",ECD,DFN,ON,DA)) Q:'DA  Q:ECXERR  I $D(^ECX(728.113,DA,0)) S EC=^(0) Q:ECXERR  D
-        ..S ECDRG=$P(EC,U,4)
-        ..S SA=$S($P(EC,U,8)]"":"A",$P(EC,U,9):"S",1:"")
-        ..; set up new record for first DA for this drug
-        ..I '$D(^TMP($J,SA,ECDRG)) D
-        ...S ECQTY=+$S(SA="A":+$P(EC,U,7),SA="S":+$P(EC,U,9),1:0)
-        ...S ECUNIT=$S(SA="A":$P(EC,U,8),SA="S":"ML",1:"")
-        ...S ECCOST=$P(EC,U,12),ECDFN=DFN
-        ...S ^TMP($J,SA,ECDRG)=ECUNIT_U_ECD_U_ECDFN_U_ECCOST_U_ECQTY
-        ...S ^(ECDRG,1)=0
-        ..; add to qty (0,1, or -1) to total
-        ..S ^TMP($J,SA,ECDRG,1)=^TMP($J,SA,ECDRG,1)+$S($P(EC,U,6)=1:1,$P(EC,U,6)=4:0,1:-1)
-        .; looped thru all DAs for this order - now check for unusual volumes
-        .F SA="S","A" S ECDRG="" F  S ECDRG=$O(^TMP($J,SA,ECDRG)) Q:ECDRG=""  Q:ECXERR  D
-        ..S ECQTY=$P(^TMP($J,SA,ECDRG),U,5),ECCOUNT=^(ECDRG,1)
-        ..S ECQTY=ECQTY*ECCOUNT
-        ..; check to see if quantity is outside of threshold range
-        ..I (ECQTY>ECTHLD)!(ECQTY<-ECTHLD) D
-        ...S ECUNIT=$P(^TMP($J,SA,ECDRG),U)
-        ...S ECDAY=$P(^(ECDRG),U,2)
-        ...S ECDFN=$P(^(ECDRG),U,3)
-        ...S ECCOST=$P(^(ECDRG),U,4)*ECCOUNT
-        ...D FILE Q:ECXERR
-        K ^TMP($J,"A"),^("S")
-        Q
-        ;
-UDP     ; entry point for UDP data
-        N ECXJ,ECDATA
-        F  S ECD=$O(^ECX(728.904,"A",ECD)) Q:'ECD  Q:ECD>ECED  Q:ECXERR  D
-        .S ECXJ=0 F  S ECXJ=$O(^ECX(728.904,"A",ECD,ECXJ)) Q:'ECXJ  Q:ECXERR  I $D(^ECX(728.904,ECXJ,0)) D
-        ..S DATA=^ECX(728.904,ECXJ,0),ECQTY=$P(DATA,U,5)
-        ..;check to see if quantity>threshold
-        ..I ECQTY>ECTHLD D
-        ...S ECDFN=$P(DATA,U,2),ECDRG=$P(DATA,U,4),ECCOST=$P(DATA,U,8),ECDAY=ECD
-        ...D FILE Q:ECXERR
-        Q
-        ;
-FILE    ; put records in temp file to print later
-        N OK,ECXPAT,ECNAME,ECSSN,ECGNAME,ECNDC,ECPROD,ECFKEY,ECXPHA
-        ; get demographics
-        S OK=$$PAT^ECXUTL3(ECDFN,$P(ECD,"."),"1;",.ECXPAT)
-        I 'OK Q
-        S ECNAME=ECXPAT("NAME")
-        S ECSSN=ECXPAT("SSN")
-        S ECDAY=$E(ECDAY,4,5)_"/"_$E(ECDAY,6,7)
-        ; get drug file data
-        S ECXPHA="",ECXPHA=$$PHAAPI^ECXUTL5(ECDRG)
-        S ECGNAME=$P(ECXPHA,U)
-        S ECNDC=$P(ECXPHA,U,3)
-        S ECNDC=$$RJ^XLFSTR($P(ECNDC,"-"),6,0)_$$RJ^XLFSTR($P(ECNDC,"-",2),4,0)_$$RJ^XLFSTR($P(ECNDC,"-",3),2,0)
-        S ECNDC=$TR(ECNDC,"*",0)
-        S ECPROD=$P(ECXPHA,U,6)
-        S ECPROD=$$RJ^XLFSTR(ECPROD,5,0)
-        S ECFKEY=ECPROD_ECNDC
-        I ECXOPT'=2 S ECUNIT=$P(ECXPHA,U,8)
-        ; file 
-        S ^TMP($J,ECFKEY,-ECQTY,ECDAY,ECSSN)=ECNAME_U_ECSSN_U_ECDAY_U_ECGNAME_U_ECFKEY_U_ECQTY_U_ECUNIT_U_"$"_$FNUMBER(ECCOST,",",2)_U_ECDS
-        S COUNT=COUNT+1
-        I COUNT#100=0 I $$S^ZTLOAD S (ZSTOP,ECXERR)=1
-        Q
-        ;
-EXIT    S ECXERR=1 Q
+ECXAPHA2 ;ALB/TMD-Pharmacy Extracts Unusual Volumes Report ; 2/06/07 10:36am
+ ;;3.0;DSS EXTRACTS;**40,49,84,104**;Dec 22, 1997;Build 8
+ ;
+EN ; entry point
+ N COUNT,ECUNIT,LINE,ECDFN,ECD,ECDRG,ECDAY,ECDFN,ECQTY,ECUNIT,ECCOST,ECDS
+ K ^TMP($J)
+ S (COUNT,ECDS)=0,ECUNIT=""
+ S ECD=ECSD1,ECED=ECED+.3
+ S LINE=$S(ECXOPT=1:"PRE",ECXOPT=2:"IVP",ECXOPT=3:"UDP",1:"EXIT")
+ D @LINE
+ Q
+ ;
+PRE ; entry point for PRE data
+ ; order through fills, refills and partial refills
+ N ECRFL,ECRX,ECREF,ECDATA,ECDATA1,ECPRC
+ S ECREF=1
+ F  S ECD=$O(^PSRX("AL",ECD)),ECRX=0 Q:'ECD  Q:ECD>ECED  Q:ECXERR  F  S ECRX=$O(^PSRX("AL",ECD,ECRX)),ECRFL="" Q:'ECRX  Q:ECXERR  F  S ECRFL=$O(^PSRX("AL",ECD,ECRX,ECRFL)) Q:ECRFL=""  Q:ECXERR  D PRE2
+ S ECD=ECSD1,ECREF="P"
+ F  S ECD=$O(^PSRX("AM",ECD)),ECRX=0 Q:'ECD  Q:ECD>ECED  Q:ECXERR  F  S ECRX=$O(^PSRX("AM",ECD,ECRX)),ECRFL="" Q:'ECRX  F  S ECRFL=$O(^PSRX("AM",ECD,ECRX,ECRFL)) Q:ECRFL=""  Q:ECXERR  D PRE2
+ Q
+ ;
+PRE2 ; get Prescription data
+ S ECDATA=$G(^PSRX(ECRX,0))
+ I ECRFL D
+ .S ECDATA1=$G(^PSRX(ECRX,ECREF,ECRFL,0))
+ .S ECQTY=+$P(ECDATA1,U,4)
+ .S ECDS=+$P(ECDATA1,U,10)
+ .S ECPRC=+$P(ECDATA1,U,11)
+ I 'ECRFL D
+ .S ECQTY=+$P(ECDATA,U,7)
+ .S ECDS=+$P(ECDATA,U,8)
+ .S ECPRC=+$P(ECDATA,U,17)
+ ;check to see if quantity>threshold
+ I ECQTY>ECTHLD D
+ .S ECDAY=ECD
+ .S ECDFN=$P(ECDATA,U,2)
+ .S ECDRG=+$P(ECDATA,U,6)
+ .S ECCOST=ECQTY*ECPRC
+ .D FILE Q:ECXERR
+ Q
+ ;
+IVP ; entry point for IVP Data
+ N DFN,ON,DA,SA,ECCOUNT
+ F  S ECD=$O(^ECX(728.113,"A",ECD)),DFN=0 Q:'ECD  Q:ECD>ECED  Q:ECXERR  F  S DFN=$O(^ECX(728.113,"A",ECD,DFN)),ON=0  Q:'DFN  F  S ON=$O(^ECX(728.113,"A",ECD,DFN,ON)),DA=0 Q:'ON  K ^TMP($J,"A"),^("S") D  Q:ECXERR
+ .F  S DA=$O(^ECX(728.113,"A",ECD,DFN,ON,DA)) Q:'DA  Q:ECXERR  I $D(^ECX(728.113,DA,0)) S EC=^(0) Q:ECXERR  D
+ ..S ECDRG=$P(EC,U,4)
+ ..S SA=$S($P(EC,U,8)]"":"A",$P(EC,U,9):"S",1:"")
+ ..; set up new record for first DA for this drug
+ ..I '$D(^TMP($J,SA,ECDRG)) D
+ ...S ECQTY=+$S(SA="A":+$P(EC,U,7),SA="S":+$P(EC,U,9),1:0)
+ ...S ECUNIT=$S(SA="A":$P(EC,U,8),SA="S":"ML",1:"")
+ ...S ECCOST=$P(EC,U,12),ECDFN=DFN
+ ...S ^TMP($J,SA,ECDRG)=ECUNIT_U_ECD_U_ECDFN_U_ECCOST_U_ECQTY
+ ...S ^(ECDRG,1)=0
+ ..; add to qty (0,1, or -1) to total
+ ..S ^TMP($J,SA,ECDRG,1)=^TMP($J,SA,ECDRG,1)+$S($P(EC,U,6)=1:1,$P(EC,U,6)=4:0,1:-1)
+ .; looped thru all DAs for this order - now check for unusual volumes
+ .F SA="S","A" S ECDRG="" F  S ECDRG=$O(^TMP($J,SA,ECDRG)) Q:ECDRG=""  Q:ECXERR  D
+ ..S ECQTY=$P(^TMP($J,SA,ECDRG),U,5),ECCOUNT=^(ECDRG,1)
+ ..S ECQTY=ECQTY*ECCOUNT
+ ..; check to see if quantity is outside of threshold range
+ ..I (ECQTY>ECTHLD)!(ECQTY<-ECTHLD) D
+ ...S ECUNIT=$P(^TMP($J,SA,ECDRG),U)
+ ...S ECDAY=$P(^(ECDRG),U,2)
+ ...S ECDFN=$P(^(ECDRG),U,3)
+ ...S ECCOST=$P(^(ECDRG),U,4)*ECCOUNT
+ ...D FILE Q:ECXERR
+ K ^TMP($J,"A"),^("S")
+ Q
+ ;
+UDP ; entry point for UDP data
+ N ECXJ,ECDATA
+ F  S ECD=$O(^ECX(728.904,"A",ECD)) Q:'ECD  Q:ECD>ECED  Q:ECXERR  D
+ .S ECXJ=0 F  S ECXJ=$O(^ECX(728.904,"A",ECD,ECXJ)) Q:'ECXJ  Q:ECXERR  I $D(^ECX(728.904,ECXJ,0)) D
+ ..S DATA=^ECX(728.904,ECXJ,0),ECQTY=$P(DATA,U,5)
+ ..;check to see if quantity>threshold
+ ..I ECQTY>ECTHLD D
+ ...S ECDFN=$P(DATA,U,2),ECDRG=$P(DATA,U,4),ECCOST=$P(DATA,U,8),ECDAY=ECD
+ ...D FILE Q:ECXERR
+ Q
+ ;
+FILE ; put records in temp file to print later
+ N OK,ECXPAT,ECNAME,ECSSN,ECGNAME,ECNDC,ECPROD,ECFKEY,ECXPHA
+ ; get demographics
+ S OK=$$PAT^ECXUTL3(ECDFN,$P(ECD,"."),"1;",.ECXPAT)
+ I 'OK Q
+ S ECNAME=ECXPAT("NAME")
+ S ECSSN=ECXPAT("SSN")
+ S ECDAY=$E(ECDAY,4,5)_"/"_$E(ECDAY,6,7)
+ ; get drug file data
+ S ECXPHA="",ECXPHA=$$PHAAPI^ECXUTL5(ECDRG)
+ S ECGNAME=$P(ECXPHA,U)
+ S ECNDC=$P(ECXPHA,U,3)
+ S ECNDC=$$RJ^XLFSTR($P(ECNDC,"-"),6,0)_$$RJ^XLFSTR($P(ECNDC,"-",2),4,0)_$$RJ^XLFSTR($P(ECNDC,"-",3),2,0)
+ S ECNDC=$TR(ECNDC,"*",0)
+ S ECPROD=$P(ECXPHA,U,6)
+ S ECPROD=$$RJ^XLFSTR(ECPROD,5,0)
+ S ECFKEY=ECPROD_ECNDC
+ I ECXOPT'=2 S ECUNIT=$P(ECXPHA,U,8)
+ ; file 
+ S ^TMP($J,ECFKEY,-ECQTY,ECDAY,ECSSN)=ECNAME_U_ECSSN_U_ECDAY_U_ECGNAME_U_ECFKEY_U_ECQTY_U_ECUNIT_U_"$"_$FNUMBER(ECCOST,",",2)_U_ECDS
+ S COUNT=COUNT+1
+ I COUNT#100=0 I $$S^ZTLOAD S (ZSTOP,ECXERR)=1
+ Q
+ ;
+EXIT S ECXERR=1 Q

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXATRT.m

@@ -1 @@
-ECXATRT ;ALB/JAP - TRT Extract Audit Report ;O4/12/2007
-        ;;3.0;DSS EXTRACTS;**1,6,8,107,105**;Dec 22, 1997;Build 70
-        ;
-EN      ;entry point for TRT extract audit report
-        N %X,%Y,X,Y,DIC,DA,DR,DIQ,DIR
-        S ECXERR=0
-        ;ecxaud=0 for 'extract' audit
-        S ECXHEAD="TRT",ECXAUD=0
-        W !!,"Setup for ",ECXHEAD," Extract Audit Report --",!!
-        ;select extract
-        D AUDIT^ECXUTLA(ECXHEAD,.ECXERR,.ECXARRAY,ECXAUD)
-        Q:ECXERR
-        ;currently, this extract does not capture divisional data
-        S ECXALL=1
-        D TRT^ECXDVSN(.ECXDIV,ECXALL,.ECXERR)
-        I ECXERR=1 D  Q
-        .W !!,?5,"Try again later... exiting.",!
-        .D AUDIT^ECXKILL
-        ;determine output device and queue if requested
-        W !
-        S ECXPGM="PROCESS^ECXATRT",ECXDESC="TRT Extract Audit Report"
-        S ECXSAVE("ECXHEAD")="",ECXSAVE("ECXALL")="",ECXSAVE("ECXDIV(")="",ECXSAVE("ECXARRAY(")=""
-        W !
-        D DEVICE^ECXUTLA(ECXPGM,ECXDESC,.ECXSAVE)
-        I ECXSAVE("POP")=1 D  Q
-        .W !!,?5,"Try again later... exiting.",!
-        .D AUDIT^ECXKILL
-        I ECXSAVE("ZTSK")=0 D
-        .K ECXSAVE,ECXPGM,ECXDESC
-        .D PROCESS^ECXATRT
-        I IO'=IO(0) D ^%ZISC
-        D HOME^%ZIS
-        D AUDIT^ECXKILL
-        Q
-        ;
-PROCESS ;process data in file #727.817
-        N X,Y,W,DATA,DATE,DIV,IEN,TS,SPEC,FTS,FTSNM,SERV,ECX,QQFLG,CNT,A1,A2,NUM,MN,NEWFTS,NEWSPEC
-        K ^TMP($J,"ECXAUD"),^TMP($J,"ECXSPEC")
-        S (QQFLG,CNT)=0
-        S ECXEXT=ECXARRAY("EXTRACT"),ECXDEF=ECXARRAY("DEF")
-        S X=ECXARRAY("START") D ^%DT S ECXSTART=Y S X=ECXARRAY("END") D ^%DT S ECXEND=Y
-        ;get run date in external format
-        D NOW^%DTC S Y=$E(%,1,12) D DD^%DT S ECXRUN=Y
-        ;set up the specialty array for site/division
-        I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ Q
-        S DIV="" F  S DIV=$O(ECXDIV(DIV)) Q:DIV=""  D
-        .S DIC="^DIC(42.4,",DR=".01;3",DIQ(0)="E",DIQ="ECX"
-        .S SPEC="" F  S SPEC=$O(^DIC(42.4,"B",SPEC)) Q:SPEC=""  S TS=$O(^(SPEC,0)) D
-        ..K ECX S DA=TS D EN^DIQ1
-        ..S SPEC=$G(ECX(42.4,TS,.01,"E")),SERV=$G(ECX(42.4,TS,3,"E")) S:SERV="" SERV="Unknown"
-        ..S ^TMP($J,"ECXSPEC",DIV,TS)=0_U_SERV_U_SPEC,NUM(TS)=0
-        ;set up the specialty to facility treating specialty conversion array;
-        ;determine if active between ecxstart and ecxend;
-        ;ignore if facility treating specialty not active within date range of report;
-        S DIC="^DIC(45.7,",DR=".01;1",DIQ(0)="I",DIQ="ECX"
-        S FTSNM="" F  S FTSNM=$O(^DIC(45.7,"B",FTSNM)) Q:FTSNM=""  S FTS=$O(^(FTSNM,0)) D
-        .K ECX S DA=FTS D EN^DIQ1
-        .S FTSNM=$G(ECX(45.7,FTS,.01,"I")),TS=$G(ECX(45.7,FTS,1,"I"))
-        .Q:TS=""
-        .S A1=$$ACTIVE^DGACT(45.7,FTS,ECXSTART),A2=$$ACTIVE^DGACT(45.7,FTS,ECXEND)
-        .Q:A1=0&(A2=0)
-        .;num(ts) will hold the number of active facility treat. specialties (file #45.7) associated 
-        .;with this national specialty (file #42.4).
-        .I '$D(NUM(TS)) S NUM(TS)=0
-        .S ^TMP($J,"ECXTS",TS,FTS)=FTSNM,^TMP($J,"ECXREVTS",FTS)=TS,NUM(TS)=NUM(TS)+1
-        ;get extract records in date range
-        S IEN="" F  S IEN=$O(^ECX(727.817,"AC",ECXEXT,IEN)) Q:IEN=""  D  Q:QQFLG
-        .S DATA=^ECX(727.817,IEN,0),DATE=$P(DATA,U,9),DIV=$P(DATA,U,4)
-        .;currently the 4th piece of extract record is always null for trt
-        .S:DIV="" DIV=1
-        .;convert free text date to fm internal format date
-        .S $E(DATE,1,2)=$E(DATE,1,2)-17
-        .Q:$L(DATE)<7  Q:(DATE<ECXSTART)  Q:(DATE>ECXEND)
-        .I $D(ECXDIV(DIV)) D
-        ..;ts is the old specialty, newfts is the new facility treat. spec. for the movement date;
-        ..;after patch #1 'losing treating specialty los' field (#17) is non-null only for actual specialty changes;
-        ..;so should be able to distinguish true ts changes from provider-only changes;
-        ..;although it will still be possible that old and new specialty are the same, but facility
-        ..;treat. spec. was changed, but we've lost that info in the extract.
-        ..;
-        ..;filter out those records which are definitely provider-only changes;
-        ..;these are the records that have 'losing treating specialty los' which is null;
-        ..;but for extracts done prior to patch #1, still need to compare old & new specialty.
-        ..;
-        ..;convert 15th and 16th piece from PTF code back to Specialty
-        ..;ECX*3.0*107
-        ..;
-        ..N ECXTS
-        ..S ECXTS=$P(DATA,U,15) I ECXTS'="" S ECXTS=$O(^DIC(42.4,"C",$G(ECXTS),0)),$P(DATA,U,15)=ECXTS
-        ..S ECXTS=$P(DATA,U,16) I ECXTS'="" S ECXTS=$O(^DIC(42.4,"C",$G(ECXTS),0)),$P(DATA,U,16)=ECXTS
-        ..S NEWTS=$P(DATA,U,15),TS=$P(DATA,U,16),LOS=$P(DATA,U,17)
-        ..;leaving this next line in here for v3.0 extracts done prior to patch #1
-        ..Q:(NUM(+TS)=1)&(NEWTS=TS)
-        ..Q:LOS=""
-        ..S $P(^(TS),U,1)=$P(^TMP($J,"ECXSPEC",DIV,TS),U,1)+1,CNT=CNT+1
-        ..I $D(ZTQUEUED),(CNT>499),'(CNT#500),$$S^%ZTLOAD S QQFLG=1,ZTSTOP=1 K ZTREQ
-        ;after all extract records processed, arrange by service and specialty;
-        ;total can only be associated with specialty, not facility treating specialty;
-        ;include specialty only if total loss is non-zero
-        I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ Q
-        S DIV="" F  S DIV=$O(ECXDIV(DIV)) Q:DIV=""  I $D(^TMP($J,"ECXSPEC",DIV)) D
-        .S TS="" F  S TS=$O(^TMP($J,"ECXSPEC",DIV,TS)) Q:TS=""  D
-        ..S TOT=+$P(^TMP($J,"ECXSPEC",DIV,TS),U,1) I TOT>0 D
-        ...S SERV=$P(^(TS),U,2),SPEC=$P(^(TS),U,3)
-        ...S ^TMP($J,"ECXAUD",DIV,SERV,SPEC)=TOT_U_TS
-        ;print the report
-        D PRINT
-        D AUDIT^ECXKILL
-        Q
-        ;
-PRINT   ;print trt data by site, by service, by specialty
-        N JJ,SS,LN,P,DIV,DIVNM,GTOT,SVCTOT,PG,QFLG,DIR,DIRUT,DTOUT,DUOUT
-        U IO
-        I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ Q
-        S (QFLG,PG)=0,$P(LN,"-",80)=""
-        ;division associated with the treat. spec. change is not actually known; division is dss site
-        S DIV="" S DIV=$O(ECXDIV(DIV)) Q:DIV=""  S GTOT=0
-        D HEADER
-        I '$D(^TMP($J,"ECXAUD",DIV)) D  Q
-        .W !!,?5,"No data available for this DSS Site.",!!
-        I $D(^TMP($J,"ECXAUD",DIV)) S SERV="" F  S SERV=$O(^TMP($J,"ECXAUD",DIV,SERV)) Q:SERV=""  D  Q:QFLG
-        .S SVCTOT=0
-        .;write the service name
-        .D:($Y+3>IOSL) HEADER Q:QFLG  W !,SERV
-        .S SPEC="" F  S SPEC=$O(^TMP($J,"ECXAUD",DIV,SERV,SPEC)) Q:SPEC=""  D  Q:QFLG
-        ..;write the specialty name and total
-        ..S TOT=$P(^TMP($J,"ECXAUD",DIV,SERV,SPEC),U,1),TS=$P(^(SPEC),U,2)
-        ..W ?22,$E(SPEC,1,30)_" ("_TS_")",?68,$$RJ^XLFSTR(TOT,5," "),!
-        ..S SVCTOT=SVCTOT+TOT,GTOT=GTOT+TOT
-        ..S FTS="" F  S FTS=$O(^TMP($J,"ECXTS",TS,FTS)) Q:FTS=""  D  Q:QFLG
-        ...S FTSNM=^TMP($J,"ECXTS",TS,FTS)
-        ...D:($Y+3>IOSL) HEADER Q:QFLG  W ?25,$E(FTSNM,1,30),!
-        .;write the service subtotal
-        .Q:QFLG
-        .W ?22,$E(LN,1,54),!
-        .D:($Y+3>IOSL) HEADER Q:QFLG  W "Total for "_SERV_":",?68,$$RJ^XLFSTR(SVCTOT,5," "),!
-        ;write the grandtotal for all services at facility
-        D:($Y+3>IOSL) HEADER Q:QFLG  W !!,"Grand Total for all Services:",?68,$$RJ^XLFSTR(GTOT,5," ")
-        ;print the audit descriptive narrative
-        I $E(IOST)'="C" D
-        .W @IOF S PG=PG+1
-        .W !,ECXARRAY("TYPE")_" ("_ECXHEAD_") Extract Audit Report"
-        .W !,"DSS Extract Log #:    "_ECXEXT
-        .W !,"Date Range of Audit:  "_ECXARRAY("START")_" to "_ECXARRAY("END")
-        .W !,"Report Run Date/Time: "_ECXRUN,?68,"Page: ",PG
-        .W !!,LN,!!
-        .S DIC="^ECX(727.1,",DA=ECXARRAY("DEF"),DR="1" D EN^DIQ
-        I $E(IOST)="C",'QFLG D
-        .S SS=22-$Y F JJ=1:1:SS W !
-        .S DIR(0)="E" W ! D ^DIR K DIR
-        Q
-        ;
-HEADER  ;header and page control
-        N JJ,SS
-        I $E(IOST)="C" D
-        .S SS=22-$Y F JJ=1:1:SS W !
-        .I PG>0 S DIR(0)="E" W ! D ^DIR K DIR S:'Y QFLG=1
-        Q:QFLG
-        W:$Y!($E(IOST)="C") @IOF S PG=PG+1
-        ;W !,ECXARRAY("TYPE")_" ("_ECXHEAD_") Extract Audit Report"
-        W !,"Treating Specialty Change"_" ("_ECXHEAD_") Extract Audit Report"
-        W !,"DSS Extract Log #:    "_ECXARRAY("EXTRACT")
-        W !,"Date Range of Audit:  "_ECXARRAY("START")_" to "_ECXARRAY("END")
-        W !,"Report Run Date/Time: "_ECXRUN
-        W !,"DSS Site:             "_$P(ECXDIV(DIV),U,2)_" ("_$P(ECXDIV(DIV),U,3)_")",?68,"Page: "_PG
-        W !!,"Service",?22,"Specialty (DSS Code)",?68,"# of Losses"
-        W !,?25,"Facility Treating Specialty"
-        W !,LN,!
-        Q
+ECXATRT ;ALB/JAP - TRT Extract Audit Report ;O4/12/2007
+ ;;3.0;DSS EXTRACTS;**1,6,8,107**;Dec 22, 1997;Build 9
+ ;
+EN ;entry point for TRT extract audit report
+ N %X,%Y,X,Y,DIC,DA,DR,DIQ,DIR
+ S ECXERR=0
+ ;ecxaud=0 for 'extract' audit
+ S ECXHEAD="TRT",ECXAUD=0
+ W !!,"Setup for ",ECXHEAD," Extract Audit Report --",!!
+ ;select extract
+ D AUDIT^ECXUTLA(ECXHEAD,.ECXERR,.ECXARRAY,ECXAUD)
+ Q:ECXERR
+ ;currently, this extract does not capture divisional data
+ S ECXALL=1
+ D TRT^ECXDVSN(.ECXDIV,ECXALL,.ECXERR)
+ I ECXERR=1 D  Q
+ .W !!,?5,"Try again later... exiting.",!
+ .D AUDIT^ECXKILL
+ ;determine output device and queue if requested
+ W !
+ S ECXPGM="PROCESS^ECXATRT",ECXDESC="TRT Extract Audit Report"
+ S ECXSAVE("ECXHEAD")="",ECXSAVE("ECXALL")="",ECXSAVE("ECXDIV(")="",ECXSAVE("ECXARRAY(")=""
+ W !
+ D DEVICE^ECXUTLA(ECXPGM,ECXDESC,.ECXSAVE)
+ I ECXSAVE("POP")=1 D  Q
+ .W !!,?5,"Try again later... exiting.",!
+ .D AUDIT^ECXKILL
+ I ECXSAVE("ZTSK")=0 D
+ .K ECXSAVE,ECXPGM,ECXDESC
+ .D PROCESS^ECXATRT
+ I IO'=IO(0) D ^%ZISC
+ D HOME^%ZIS
+ D AUDIT^ECXKILL
+ Q
+ ;
+PROCESS ;process data in file #727.817
+ N X,Y,W,DATA,DATE,DIV,IEN,TS,SPEC,FTS,FTSNM,SERV,ECX,QQFLG,CNT,A1,A2,NUM,MN,NEWFTS,NEWSPEC
+ K ^TMP($J,"ECXAUD"),^TMP($J,"ECXSPEC")
+ S (QQFLG,CNT)=0
+ S ECXEXT=ECXARRAY("EXTRACT"),ECXDEF=ECXARRAY("DEF")
+ S X=ECXARRAY("START") D ^%DT S ECXSTART=Y S X=ECXARRAY("END") D ^%DT S ECXEND=Y
+ ;get run date in external format
+ D NOW^%DTC S Y=$E(%,1,12) D DD^%DT S ECXRUN=Y
+ ;set up the specialty array for site/division
+ I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ Q
+ S DIV="" F  S DIV=$O(ECXDIV(DIV)) Q:DIV=""  D
+ .S DIC="^DIC(42.4,",DR=".01;3",DIQ(0)="E",DIQ="ECX"
+ .S SPEC="" F  S SPEC=$O(^DIC(42.4,"B",SPEC)) Q:SPEC=""  S TS=$O(^(SPEC,0)) D
+ ..K ECX S DA=TS D EN^DIQ1
+ ..S SPEC=$G(ECX(42.4,TS,.01,"E")),SERV=$G(ECX(42.4,TS,3,"E")) S:SERV="" SERV="Unknown"
+ ..S ^TMP($J,"ECXSPEC",DIV,TS)=0_U_SERV_U_SPEC,NUM(TS)=0
+ ;set up the specialty to facility treating specialty conversion array;
+ ;determine if active between ecxstart and ecxend;
+ ;ignore if facility treating specialty not active within date range of report;
+ S DIC="^DIC(45.7,",DR=".01;1",DIQ(0)="I",DIQ="ECX"
+ S FTSNM="" F  S FTSNM=$O(^DIC(45.7,"B",FTSNM)) Q:FTSNM=""  S FTS=$O(^(FTSNM,0)) D
+ .K ECX S DA=FTS D EN^DIQ1
+ .S FTSNM=$G(ECX(45.7,FTS,.01,"I")),TS=$G(ECX(45.7,FTS,1,"I"))
+ .Q:TS=""
+ .S A1=$$ACTIVE^DGACT(45.7,FTS,ECXSTART),A2=$$ACTIVE^DGACT(45.7,FTS,ECXEND)
+ .Q:A1=0&(A2=0)
+ .;num(ts) will hold the number of active facility treat. specialties (file #45.7) associated 
+ .;with this national specialty (file #42.4).
+ .I '$D(NUM(TS)) S NUM(TS)=0
+ .S ^TMP($J,"ECXTS",TS,FTS)=FTSNM,^TMP($J,"ECXREVTS",FTS)=TS,NUM(TS)=NUM(TS)+1
+ ;get extract records in date range
+ S IEN="" F  S IEN=$O(^ECX(727.817,"AC",ECXEXT,IEN)) Q:IEN=""  D  Q:QQFLG
+ .S DATA=^ECX(727.817,IEN,0),DATE=$P(DATA,U,9),DIV=$P(DATA,U,4)
+ .;currently the 4th piece of extract record is always null for trt
+ .S:DIV="" DIV=1
+ .;convert free text date to fm internal format date
+ .S $E(DATE,1,2)=$E(DATE,1,2)-17
+ .Q:$L(DATE)<7  Q:(DATE<ECXSTART)  Q:(DATE>ECXEND)
+ .I $D(ECXDIV(DIV)) D
+ ..;ts is the old specialty, newfts is the new facility treat. spec. for the movement date;
+ ..;after patch #1 'losing treating specialty los' field (#17) is non-null only for actual specialty changes;
+ ..;so should be able to distinguish true ts changes from provider-only changes;
+ ..;although it will still be possible that old and new specialty are the same, but facility
+ ..;treat. spec. was changed, but we've lost that info in the extract.
+ ..;
+ ..;filter out those records which are definitely provider-only changes;
+ ..;these are the records that have 'losing treating specialty los' which is null;
+ ..;but for extracts done prior to patch #1, still need to compare old & new specialty.
+ ..;
+ ..;convert 15th and 16th piece from PTF code back to Specialty
+ ..;ECX*3.0*107
+ ..;
+ ..N ECXTS
+ ..S ECXTS=$P(DATA,U,15),ECXTS=$O(^DIC(42.4,$G(ECXTS),"C",$P(DATA,U,15),0)),$P(DATA,U,15)=ECXTS
+ ..S ECXTS=$P(DATA,U,16),ECXTS=$O(^DIC(42.4,$G(ECXTS),"C",$P(DATA,U,16),0)),$P(DATA,U,16)=ECXTS
+ ..S NEWTS=$P(DATA,U,15),TS=$P(DATA,U,16),LOS=$P(DATA,U,17)
+ ..;leaving this next line in here for v3.0 extracts done prior to patch #1
+ ..Q:(NUM(TS)=1)&(NEWTS=TS)
+ ..Q:LOS=""
+ ..S $P(^(TS),U,1)=$P(^TMP($J,"ECXSPEC",DIV,TS),U,1)+1,CNT=CNT+1
+ ..I $D(ZTQUEUED),(CNT>499),'(CNT#500),$$S^%ZTLOAD S QQFLG=1,ZTSTOP=1 K ZTREQ
+ ;after all extract records processed, arrange by service and specialty;
+ ;total can only be associated with specialty, not facility treating specialty;
+ ;include specialty only if total loss is non-zero
+ I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ Q
+ S DIV="" F  S DIV=$O(ECXDIV(DIV)) Q:DIV=""  I $D(^TMP($J,"ECXSPEC",DIV)) D
+ .S TS="" F  S TS=$O(^TMP($J,"ECXSPEC",DIV,TS)) Q:TS=""  D
+ ..S TOT=+$P(^TMP($J,"ECXSPEC",DIV,TS),U,1) I TOT>0 D
+ ...S SERV=$P(^(TS),U,2),SPEC=$P(^(TS),U,3)
+ ...S ^TMP($J,"ECXAUD",DIV,SERV,SPEC)=TOT_U_TS
+ ;print the report
+ D PRINT
+ D AUDIT^ECXKILL
+ Q
+ ;
+PRINT ;print trt data by site, by service, by specialty
+ N JJ,SS,LN,P,DIV,DIVNM,GTOT,SVCTOT,PG,QFLG,DIR,DIRUT,DTOUT,DUOUT
+ U IO
+ I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ Q
+ S (QFLG,PG)=0,$P(LN,"-",80)=""
+ ;division associated with the treat. spec. change is not actually known; division is dss site
+ S DIV="" S DIV=$O(ECXDIV(DIV)) Q:DIV=""  S GTOT=0
+ D HEADER
+ I '$D(^TMP($J,"ECXAUD",DIV)) D  Q
+ .W !!,?5,"No data available for this DSS Site.",!!
+ I $D(^TMP($J,"ECXAUD",DIV)) S SERV="" F  S SERV=$O(^TMP($J,"ECXAUD",DIV,SERV)) Q:SERV=""  D  Q:QFLG
+ .S SVCTOT=0
+ .;write the service name
+ .D:($Y+3>IOSL) HEADER Q:QFLG  W !,SERV
+ .S SPEC="" F  S SPEC=$O(^TMP($J,"ECXAUD",DIV,SERV,SPEC)) Q:SPEC=""  D  Q:QFLG
+ ..;write the specialty name and total
+ ..S TOT=$P(^TMP($J,"ECXAUD",DIV,SERV,SPEC),U,1),TS=$P(^(SPEC),U,2)
+ ..W ?22,$E(SPEC,1,30)_" ("_TS_")",?68,$$RJ^XLFSTR(TOT,5," "),!
+ ..S SVCTOT=SVCTOT+TOT,GTOT=GTOT+TOT
+ ..S FTS="" F  S FTS=$O(^TMP($J,"ECXTS",TS,FTS)) Q:FTS=""  D  Q:QFLG
+ ...S FTSNM=^TMP($J,"ECXTS",TS,FTS)
+ ...D:($Y+3>IOSL) HEADER Q:QFLG  W ?25,$E(FTSNM,1,30),!
+ .;write the service subtotal
+ .Q:QFLG
+ .W ?22,$E(LN,1,54),!
+ .D:($Y+3>IOSL) HEADER Q:QFLG  W "Total for "_SERV_":",?68,$$RJ^XLFSTR(SVCTOT,5," "),!
+ ;write the grandtotal for all services at facility
+ D:($Y+3>IOSL) HEADER Q:QFLG  W !!,"Grand Total for all Services:",?68,$$RJ^XLFSTR(GTOT,5," ")
+ ;print the audit descriptive narrative
+ I $E(IOST)'="C" D
+ .W @IOF S PG=PG+1
+ .W !,ECXARRAY("TYPE")_" ("_ECXHEAD_") Extract Audit Report"
+ .W !,"DSS Extract Log #:    "_ECXEXT
+ .W !,"Date Range of Audit:  "_ECXARRAY("START")_" to "_ECXARRAY("END")
+ .W !,"Report Run Date/Time: "_ECXRUN,?68,"Page: ",PG
+ .W !!,LN,!!
+ .S DIC="^ECX(727.1,",DA=ECXARRAY("DEF"),DR="1" D EN^DIQ
+ I $E(IOST)="C",'QFLG D
+ .S SS=22-$Y F JJ=1:1:SS W !
+ .S DIR(0)="E" W ! D ^DIR K DIR
+ Q
+ ;
+HEADER ;header and page control
+ N JJ,SS
+ I $E(IOST)="C" D
+ .S SS=22-$Y F JJ=1:1:SS W !
+ .I PG>0 S DIR(0)="E" W ! D ^DIR K DIR S:'Y QFLG=1
+ Q:QFLG
+ W:$Y!($E(IOST)="C") @IOF S PG=PG+1
+ ;W !,ECXARRAY("TYPE")_" ("_ECXHEAD_") Extract Audit Report"
+ W !,"Treating Specialty Change"_" ("_ECXHEAD_") Extract Audit Report"
+ W !,"DSS Extract Log #:    "_ECXARRAY("EXTRACT")
+ W !,"Date Range of Audit:  "_ECXARRAY("START")_" to "_ECXARRAY("END")
+ W !,"Report Run Date/Time: "_ECXRUN
+ W !,"DSS Site:             "_$P(ECXDIV(DIV),U,2)_" ("_$P(ECXDIV(DIV),U,3)_")",?68,"Page: "_PG
+ W !!,"Service",?22,"Specialty (DSS Code)",?68,"# of Losses"
+ W !,?25,"Facility Treating Specialty"
+ W !,LN,!
+ Q

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXDIVIV.m

@@ -1 @@
-ECXDIVIV        ;BIR/CML-Enter/Edit and Print IV Room Division ; 3/13/07 10:48am
-        ;;3.0;DSS EXTRACTS;**8,105**;Dec 22, 1997;Build 70
-        ;
-ED      ;enter/edit division field for iv rooms
-        N CHKFLG,DIC,DIE,DA,DR
-        W !!,"This option allows editing of the DIVISION field for IV Rooms.",!
-        S CHKFLG=0,OUT=0
-        D CHK Q:CHKFLG
-        F  D  Q:OUT
-        .W ! S DIC=59.5,DIC(0)="QEAMZ" D ^DIC
-        .I Y<0 S OUT=1 Q
-        .I $G(^PS(59.5,+Y,"I"))]"" W "   *INACTIVE*",$C(7)
-        .S DIE=DIC,DA=+Y
-        .S DR=.02 D ^DIE K DA
-        Q
-        ;
-PRT     ;print worksheet
-        W !!,"This option will produce a worksheet listing all entries in the IV Room file"
-        W !,"(#59.5).  It should be used to help DSS and Pharmacy services define and"
-        W !,"review the DIVISION assignments for each IV Room.",!! S QFLG=0
-        S QFLG=0,CHKFLG=0
-        D CHK Q:CHKFLG
-        D EN^XUTMDEVQ("START^ECXDIVIV","DSS - IV Room List")
-        I POP D
-        .W !,"NO DEVICE SELECTED OR REPORT PRINTED!!"
-        .D PAUSE
-        K ^TMP($J,"ECXDSS")
-        Q
-        ;
-START   ;queued entry point
-        N CHKFLG,DIV,DIVNM,INACT,IV,IVRM,JJ,LN1,LN2,PDT,PG,QFLG,SS,X,Y
-        I '$D(DT) S DT=$$HTFM^XLFDT(+$H)
-        K ^TMP("ECXDIVIV",$J),^TMP($J,"ECXDSS") S QFLG=0,IV=0
-        ;call pharmacy encapsulation api and return all iv rooms information
-        D ALL^PSJ59P5(,"??","ECXDSS")
-        F  S IV=$O(^TMP($J,"ECXDSS",IV)) Q:'IV  D
-        .S IVRM=$G(^TMP($J,"ECXDSS",IV,.01)),DIV=$P($G(^(.02)),U)
-        .S DIVNM=$S(DIV="":"ZZZ",1:$E($P(^DG(40.8,DIV,0),U),1,30))
-        .K INACT I $P($G(^TMP($J,"ECXDSS",IV,19)),U)]"" S INACT=$P(^(19),U,2)
-        .S ^TMP("ECXDIVIV",$J,DIVNM,IVRM)=$S($D(INACT):INACT,1:"")
-        ;print report
-        S PG=0,PDT=$$FMTE^XLFDT(DT),$P(LN1,"-",81)="",$P(LN2,"_",30)=""
-        D HDR
-        I '$D(^TMP("ECXDIVIV",$J)) W !!,"No Data found for this worksheet."
-        I $D(^TMP("ECXDIVIV",$J)) S DIVNM="" D
-        .F  S DIVNM=$O(^TMP("ECXDIVIV",$J,DIVNM)) Q:DIVNM=""  Q:QFLG  D
-        ..S IVRM=""
-        ..F  S IVRM=$O(^TMP("ECXDIVIV",$J,DIVNM,IVRM)) Q:IVRM=""  Q:QFLG  D
-        ...S INACT=^TMP("ECXDIVIV",$J,DIVNM,IVRM)
-        ...D:$Y+4>IOSL HDR Q:QFLG
-        ...W !!,IVRM,?34,$S(DIVNM="ZZZ":LN2,1:DIVNM),?60,INACT
-        I $E(IOST)="C"&('QFLG) D PAUSE
-        K ^TMP("ECXDIVIV",$J) S:$D(ZTQUEUED) ZTREQ="@"
-        W:$E(IOST)'="C" @IOF
-        D ^%ZISC
-        Q
-        ;
-HDR     ;header
-        I $E(IOST)="C" S SS=22-$Y F JJ=1:1:SS W !
-        I $E(IOST)="C",PG>0 S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1
-        Q:QFLG
-        S PG=PG+1 W:$Y!($E(IOST)="C") @IOF
-        W !,"IV Room Worksheet",?72,"Page: ",PG,!,"Printed ",PDT
-        W !!,"IV ROOM",?34,"DIVISION",?60,"INACTIVE DATE",!,LN1
-        Q
-        ;
-CHK     ;check for existence of necessary files for division functionality
-        S CHKFLG=0
-        D ALL^PSJ59P5(,"??","ECXIV")
-        I '$O(^TMP($J,"ECXIV",0)) D  I CHKFLG D EXIT Q
-        .W !,"The IV Room file (#59.5) does not exist!"
-        .S CHKFLG=1 D PAUSE
-        I '$D(^ECX(728.113,0)) D  I CHKFLG D EXIT Q
-        .W $C(7),!!,"Your facility appears to be running a version of Inpatient Medications prior to"
-        .W !,"version 4.5 which is necessary to use this option."
-        .S CHKFLG=1 D PAUSE
-        I '$D(^TMP($J,"ECXIV",$O(^TMP($J,"ECXIV",0)),.02)) D
-        .W $C(7),!!,"The Inpatient Medications Patch PSJ*4.5*27 has not yet been installed!"
-        .W !,"It must be loaded before you can proceed with this option."
-        .S CHKFLG=1 D PAUSE
-EXIT    K ^TMP($J,"ECXIV")
-        Q
-        ;
-PAUSE   ;pause screen
-        I $E(IOST)="C" D
-        .S SS=22-$Y F JJ=1:1:SS W !
-        .S DIR(0)="E" W ! D ^DIR K DIR
-        Q
+ECXDIVIV ;BIR/CML-Enter/Edit and Print IV Room Division ; [ 11/15/96  11:12 AM ]
+ ;;3.0;DSS EXTRACTS;**8**;Dec 22, 1997
+ ;
+ED ;enter/edit division field for iv rooms
+ N CHKFLG,DIC,DIE,DA,DR
+ W !!,"This option allows editing of the DIVISION field for IV Rooms.",!
+ S CHKFLG=0,OUT=0
+ D CHK Q:CHKFLG
+ F  D  Q:OUT
+ .W ! S DIC=59.5,DIC(0)="QEAMZ" D ^DIC
+ .I Y<0 S OUT=1 Q
+ .I $G(^PS(59.5,+Y,"I"))]"" W "   *INACTIVE*",$C(7)
+ .S DIE=DIC,DA=+Y
+ .S DR=.02 D ^DIE K DA
+ Q
+ ;
+PRT ;print worksheet
+ W !!,"This option will produce a worksheet listing all entries in the IV Room file"
+ W !,"(#59.5).  It should be used to help DSS and Pharmacy services define and"
+ W !,"review the DIVISION assignments for each IV Room.",!! S QFLG=0
+ S QFLG=0,CHKFLG=0
+ D CHK Q:CHKFLG
+ D EN^XUTMDEVQ("START^ECXDIVIV","DSS - IV Room List")
+ I POP D
+ .W !,"NO DEVICE SELECTED OR REPORT PRINTED!!"
+ .D PAUSE
+ Q
+ ;
+START ;queued entry point
+ N CHKFLG,DIV,DIVNM,INACT,IV,IVRM,JJ,LN1,LN2,PDT,PG,QFLG,SS,X,Y
+ I '$D(DT) S DT=$$HTFM^XLFDT(+$H)
+ K ^TMP("ECXDIVIV",$J) S QFLG=0,IV=0
+ F  S IV=$O(^PS(59.5,IV)) Q:'IV  I $D(^PS(59.5,IV,0)) D
+ .S IVRM=$E($P(^PS(59.5,IV,0),U),1,30),DIV=$P(^(0),U,4)
+ .S DIVNM=$S(DIV="":"ZZZ",1:$E($P(^DG(40.8,DIV,0),U),1,30))
+ .K INACT I $P($G(^PS(59.5,IV,"I")),U)]"" S INACT=$$FMTE^XLFDT($P(^PS(59.5,IV,"I"),U),1)
+ .S ^TMP("ECXDIVIV",$J,DIVNM,IVRM)=$S($D(INACT):INACT,1:"")
+ ;print report
+ S PG=0,PDT=$$FMTE^XLFDT(DT),$P(LN1,"-",81)="",$P(LN2,"_",30)=""
+ D HDR
+ I '$D(^TMP("ECXDIVIV",$J)) W !!,"No Data found for this worksheet."
+ I $D(^TMP("ECXDIVIV",$J)) S DIVNM="" D
+ .F  S DIVNM=$O(^TMP("ECXDIVIV",$J,DIVNM)) Q:DIVNM=""  Q:QFLG  D
+ ..S IVRM=""
+ ..F  S IVRM=$O(^TMP("ECXDIVIV",$J,DIVNM,IVRM)) Q:IVRM=""  Q:QFLG  D
+ ...S INACT=^TMP("ECXDIVIV",$J,DIVNM,IVRM)
+ ...D:$Y+4>IOSL HDR Q:QFLG
+ ...W !!,IVRM,?34,$S(DIVNM="ZZZ":LN2,1:DIVNM),?60,INACT
+ I $E(IOST)="C"&('QFLG) D PAUSE
+ K ^TMP("ECXDIVIV",$J) S:$D(ZTQUEUED) ZTREQ="@"
+ W:$E(IOST)'="C" @IOF
+ D ^%ZISC
+ Q
+ ;
+HDR ;header
+ I $E(IOST)="C" S SS=22-$Y F JJ=1:1:SS W !
+ I $E(IOST)="C",PG>0 S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1
+ Q:QFLG
+ S PG=PG+1 W:$Y!($E(IOST)="C") @IOF
+ W !,"IV Room Worksheet",?72,"Page: ",PG,!,"Printed ",PDT
+ W !!,"IV ROOM",?34,"DIVISION",?60,"INACTIVE DATE",!,LN1
+ Q
+ ;
+CHK ;check for existence of necessary files for division functionality
+ S CHKFLG=0
+ I '$O(^PS(59.5,0)) D  Q:CHKFLG
+ .W !,"The IV Room file (#59.5) does not exist!"
+ .S CHKFLG=1 D PAUSE
+ I '$D(^ECX(728.113,0)) D  Q:CHKFLG
+ .W $C(7),!!,"Your facility appears to be running a version of Inpatient Medications prior to"
+ .W !,"version 4.5 which is necessary to use this option."
+ .S CHKFLG=1 D PAUSE
+ K TEST1 D FIELD^DID(59.5,.02,"","TYPE","TEST1")
+ I '$D(TEST1) D
+ .W $C(7),!!,"The Inpatient Medications Patch PSJ*4.5*27 has not yet been installed!"
+ .W !,"It must be loaded before you can proceed with this option."
+ .S CHKFLG=1 D PAUSE
+ Q
+ ;
+PAUSE ;pause screen
+ I $E(IOST)="C" D
+ .S SS=22-$Y F JJ=1:1:SS W !
+ .S DIR(0)="E" W ! D ^DIR K DIR
+ Q

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXDRUG2.m

@@ -1 @@
-ECXDRUG2        ;ALB/TMD-Pharmacy Extracts Incomplete Feeder Key Report ; 2/19/08 3:44pm
-        ;;3.0;DSS EXTRACTS;**40,68,84,105,111**;Dec 22, 1997;Build 4
-        ;
-EN      ; entry point
-        N ECD,LINE,ECDRG,ECQTY,ECPRC
-        K ^TMP($J)
-        S ECD=ECSD1,ECED=ECED+.3
-        S LINE=$S(ECXOPT=1:"PRE",ECXOPT=2:"IVP",ECXOPT=3:"UDP",1:"EXIT")
-        D @LINE
-        Q
-        ;
-PRE     ; entry point for PRE data
-        ; order through fills, refills and partial refills
-        N ECRFL,ECRX,ECREF,ECDATA,ECDATA1
-        K ^TMP($J,"ECXDSS")
-        ;call pharmacy api pso52ex
-        D EXTRACT^PSO52EX(ECD,ECED,"ECXDSS")
-        S ECREF="RF"
-        ;order thru fills and refills; refill values 0 thru 11
-        ;     Note:  refill 0 = original fill
-        F  S ECD=$O(^TMP($J,"ECXDSS","AL",ECD)),IEN=0 Q:'ECD  Q:ECD>ECED  Q:ECXERR  F  S IEN=$O(^(ECD,IEN)),ECRFL=""  Q:'IEN  Q:ECXERR  F  S ECRFL=$O(^(IEN,ECRFL)) Q:ECRFL']""  Q:ECXERR  D PRE2
-        ;
-        ;order thru partial fills
-        S ECD=ECSD1,ECREF="P"
-        F  S ECD=$O(^TMP($J,"ECXDSS","AM",ECD)),IEN=0 Q:'ECD  Q:ECD>ECED  Q:ECXERR  F  S IEN=$O(^(ECD,IEN)),ECRFL=""  Q:'IEN  Q:ECXERR  F  S ECRFL=$O(^(IEN,ECRFL)) Q:'ECRFL  Q:ECXERR  D PRE2
-        K ^TMP($J,"ECXDSS")
-        Q
-        ;
-PRE2    ; get Prescription data
-        S ECDRG=+$P(^TMP($J,"ECXDSS",IEN,6),U)
-        I ECRFL>0&(ECREF="RF") D
-        .S ECQTY=^TMP($J,"ECXDSS",IEN,ECREF,ECRFL,1),ECPRC=^(1.2)
-        I ECRFL>0&(ECREF="P") D
-        .S ECQTY=^TMP($J,"ECXDSS",IEN,ECREF,ECRFL,.04),ECPRC=^(.042)
-        I 'ECRFL S ECQTY=^TMP($J,"ECXDSS",IEN,7),ECPRC=^(17)
-        D TEST
-        Q
-        ;
-IVP     ; entry point for IVP data
-        N ON,DFN,DA,SA
-        F  S ECD=$O(^ECX(728.113,"A",ECD)),DFN=0 Q:'ECD  Q:ECXERR  Q:ECD>ECED  F  S DFN=$O(^ECX(728.113,"A",ECD,DFN)),ON=0  Q:'DFN  Q:ECXERR  F  S ON=$O(^ECX(728.113,"A",ECD,DFN,ON)),DA=0 Q:'ON  K ^TMP($J,"A"),^("S") D
-        .F  S DA=$O(^ECX(728.113,"A",ECD,DFN,ON,DA)) Q:'DA  I $D(^ECX(728.113,DA,0)) S EC=^(0) D
-        ..S ECDRG=$P(EC,U,4)
-        ..S SA=$S($P(EC,U,8)]"":"A",$P(EC,U,9):"S",1:"")
-        ..I SA'="" D
-        ...I '$D(^TMP($J,SA,ECDRG)) S ^(ECDRG)=0,$P(^(ECDRG),U,2)=$P(EC,U,12)
-        ...S $P(^TMP($J,SA,ECDRG),U)=$P(^TMP($J,SA,ECDRG),U)+$S($P(EC,U,6)=1:1,$P(EC,U,6)=4:0,1:-1)
-        .;looped thru all DAs for this order - now put it together
-        .F SA="S","A" S ECDRG="" F  S ECDRG=$O(^TMP($J,SA,ECDRG)) Q:ECDRG=""  D
-        ..S ECQTY=$P(^TMP($J,SA,ECDRG),U),ECPRC=$P(^(ECDRG),U,2)
-        ..D TEST
-        K ^TMP($J,"A"),^TMP($J,"S")
-        Q
-        ;
-UDP     ; entry point for UDP data
-        N ECXJ,ECDATA
-        F  S ECD=$O(^ECX(728.904,"A",ECD)) Q:'ECD  Q:ECD>ECED  Q:ECXERR  D
-        .S ECXJ=0 F  S ECXJ=$O(^ECX(728.904,"A",ECD,ECXJ)) Q:'ECXJ  Q:ECXERR  I $D(^ECX(728.904,ECXJ,0)) D
-        ..S DATA=^ECX(728.904,ECXJ,0)
-        ..S ECDRG=$P(DATA,U,4),ECQTY=$P(DATA,U,5),ECCOST=$P(DATA,U,8)
-        ..S ECPRC=ECCOST/ECQTY
-        ..D TEST
-        Q
-        ;
-TEST    ; retrieve NDC and PSNDF VA Product Code Entry and test for missing NDC or VA Prod Code
-        N ECTYPE,ECNDC,ECZERO,K,ECPROD,ECFCHAR,ECSTOCK,ECXPHA
-        S ECTYPE=0,ECXPHA=""
-        ; call pharmacy drug file (#50) api via ecxutl5
-        S ECXPHA=$$PHAAPI^ECXUTL5(ECDRG)
-        S ECNDC=$P(ECXPHA,U,3)
-        S ECNDC=$$RJ^XLFSTR($P(ECNDC,"-"),6,0)_$$RJ^XLFSTR($P(ECNDC,"-",2),4,0)_$$RJ^XLFSTR($P(ECNDC,"-",3),2,0),ECNDC=$TR(ECNDC,"*",0)
-        S ECZERO=1,ECSTOCK=0 F K=1:1:$L(ECNDC) D  Q:'ECZERO!ECSTOCK
-        .S ECFCHAR=$E(ECNDC,K)
-        .I ECFCHAR="S" S ECSTOCK=1 Q
-        .I ECFCHAR'=0 S ECZERO=0 Q
-        I ECZERO!ECSTOCK!(ECNDC["N/A") S ECTYPE=2
-        S ECPROD=$P(ECXPHA,U,6),ECPROD=$$RJ^XLFSTR(ECPROD,5,0)
-        I ECTYPE,'ECPROD S ECTYPE=3
-        I 'ECTYPE,'ECPROD S ECTYPE=1
-        I ECTYPE D FILE
-        Q
-        ;
-FILE    ; file record
-        N ECFKEY,ECGNAME,STATS,ECCOUNT,QTY,COST,ECCOST
-        ; create new record if none exists for this drug
-        I '$D(^TMP($J,ECDRG)) D
-        .S ECFKEY=ECPROD_ECNDC
-        .S ECGNAME=$P($G(^PSDRUG(ECDRG,0)),U)
-        .S ^TMP($J,ECDRG)=ECGNAME_U_ECFKEY_U_ECPRC_U_ECTYPE
-        .S ^TMP($J,ECDRG,0)="0^0^0"
-        ; add stats to record
-        S STATS=^TMP($J,ECDRG,0)
-        S ECCOUNT=$P(STATS,U),QTY=$P(STATS,U,2),COST=$P(STATS,U,3)
-        S ECCOUNT=ECCOUNT+1
-        S ECCOST=ECQTY*ECPRC
-        S ECQTY=ECQTY+QTY,ECCOST=ECCOST+COST
-        S ^TMP($J,ECDRG,0)=ECCOUNT_U_ECQTY_U_ECCOST
-        Q
-        ;
-EXIT    S ECXERR=1 Q
+ECXDRUG2 ;ALB/TMD-Pharmacy Extracts Incomplete Feeder Key Report ; 6/13/05 3:31pm
+ ;;3.0;DSS EXTRACTS;**40,68,84**;Dec 22, 1997
+ ;
+EN ; entry point
+ N ECD,LINE,ECDRG,ECQTY,ECPRC
+ K ^TMP($J)
+ S ECD=ECSD1,ECED=ECED+.3
+ S LINE=$S(ECXOPT=1:"PRE",ECXOPT=2:"IVP",ECXOPT=3:"UDP",1:"EXIT")
+ D @LINE
+ Q
+ ;
+PRE ; entry point for PRE data
+ ; order through fills, refills and partial refills
+ N ECRFL,ECRX,ECREF,ECDATA,ECDATA1
+ S ECREF=1
+ F  S ECD=$O(^PSRX("AL",ECD)),ECRX=0 Q:'ECD  Q:ECD>ECED   Q:ECXERR  F  S ECRX=$O(^PSRX("AL",ECD,ECRX)),ECRFL="" Q:'ECRX  F  S ECRFL=$O(^PSRX("AL",ECD,ECRX,ECRFL)) Q:ECRFL=""  Q:ECXERR  D PRE2
+ S ECD=ECSD1,ECREF="P"
+ F  S ECD=$O(^PSRX("AM",ECD)),ECRX=0 Q:'ECD  Q:ECD>ECED  Q:ECXERR  F  S ECRX=$O(^PSRX("AM",ECD,ECRX)),ECRFL="" Q:'ECRX  F  S ECRFL=$O(^PSRX("AM",ECD,ECRX,ECRFL)) Q:ECRFL=""  D PRE2
+ Q
+ ;
+PRE2 ; get Prescription data
+ S ECDATA=$G(^PSRX(ECRX,0))
+ S ECDRG=+$P(ECDATA,U,6)
+ I ECRFL D
+ .S ECDATA1=$G(^PSRX(ECRX,ECREF,ECRFL,0))
+ .S ECQTY=+$P(ECDATA1,U,4),ECPRC=+$P(ECDATA1,U,11)
+ I 'ECRFL S ECQTY=+$P(ECDATA,U,7),ECPRC=+$P(ECDATA,U,17)
+ D TEST
+ Q
+ ;
+IVP ; entry point for IVP data
+ N ON,DFN,DA,SA
+ F  S ECD=$O(^ECX(728.113,"A",ECD)),DFN=0 Q:'ECD  Q:ECXERR  Q:ECD>ECED  F  S DFN=$O(^ECX(728.113,"A",ECD,DFN)),ON=0  Q:'DFN  Q:ECXERR  F  S ON=$O(^ECX(728.113,"A",ECD,DFN,ON)),DA=0 Q:'ON  K ^TMP($J,"A"),^("S") D
+ .F  S DA=$O(^ECX(728.113,"A",ECD,DFN,ON,DA)) Q:'DA  I $D(^ECX(728.113,DA,0)) S EC=^(0) D
+ ..S ECDRG=$P(EC,U,4)
+ ..S SA=$S($P(EC,U,8)]"":"A",$P(EC,U,9):"S",1:"")
+ ..I SA'="" D
+ ...I '$D(^TMP($J,SA,ECDRG)) S ^(ECDRG)=0,$P(^(ECDRG),U,2)=$P(EC,U,12)
+ ...S $P(^TMP($J,SA,ECDRG),U)=$P(^TMP($J,SA,ECDRG),U)+$S($P(EC,U,6)=1:1,$P(EC,U,6)=4:0,1:-1)
+ .;looped thru all DAs for this order - now put it together
+ .F SA="S","A" S ECDRG="" F  S ECDRG=$O(^TMP($J,SA,ECDRG)) Q:ECDRG=""  D
+ ..S ECQTY=$P(^TMP($J,SA,ECDRG),U),ECPRC=$P(^(ECDRG),U,2)
+ ..D TEST
+ K ^TMP($J,"A"),^TMP($J,"S")
+ Q
+ ;
+UDP ; entry point for UDP data
+ N ECXJ,ECDATA
+ F  S ECD=$O(^ECX(728.904,"A",ECD)) Q:'ECD  Q:ECD>ECED  Q:ECXERR  D
+ .S ECXJ=0 F  S ECXJ=$O(^ECX(728.904,"A",ECD,ECXJ)) Q:'ECXJ  Q:ECXERR  I $D(^ECX(728.904,ECXJ,0)) D
+ ..S DATA=^ECX(728.904,ECXJ,0)
+ ..S ECDRG=$P(DATA,U,4),ECQTY=$P(DATA,U,5),ECCOST=$P(DATA,U,8)
+ ..S ECPRC=ECCOST/ECQTY
+ ..D TEST
+ Q
+ ;
+TEST ; retrieve NDC and PSNDF VA Product Code Entry and test for missing NDC or VA Prod Code
+ N ECTYPE,ECNDC,ECZERO,K,ECPROD,ECFCHAR,ECSTOCK,ECXPHA
+ S ECTYPE=0,ECXPHA=""
+ ; call pharmacy drug file (#50) api via ecxutl5
+ S ECXPHA=$$PHAAPI^ECXUTL5(ECDRG)
+ S ECNDC=$P(ECXPHA,U,3)
+ S ECNDC=$$RJ^XLFSTR($P(ECNDC,"-"),6,0)_$$RJ^XLFSTR($P(ECNDC,"-",2),4,0)_$$RJ^XLFSTR($P(ECNDC,"-",3),2,0),ECNDC=$TR(ECNDC,"*",0)
+ S ECZERO=1,ECSTOCK=0 F K=1:1:$L(ECNDC) D  Q:'ECZERO!ECSTOCK
+ .S ECFCHAR=$E(ECNDC,K)
+ .I ECFCHAR="S" S ECSTOCK=1 Q
+ .I ECFCHAR'=0 S ECZERO=0 Q
+ I ECZERO!ECSTOCK!(ECNDC["N/A") S ECTYPE=2
+ S ECPROD=$P(ECXPHA,U,6),ECPROD=$$RJ^XLFSTR(ECPROD,5,0)
+ I ECTYPE,'ECPROD S ECTYPE=3
+ I 'ECTYPE,'ECPROD S ECTYPE=1
+ I ECTYPE D FILE
+ Q
+ ;
+FILE ; file record
+ N ECFKEY,ECGNAME,STATS,ECCOUNT,QTY,COST,ECCOST
+ ; create new record if none exists for this drug
+ I '$D(^TMP($J,ECDRG)) D
+ .S ECFKEY=ECPROD_ECNDC
+ .S ECGNAME=$P($G(^PSDRUG(ECDRG,0)),U)
+ .S ^TMP($J,ECDRG)=ECGNAME_U_ECFKEY_U_ECPRC_U_ECTYPE
+ .S ^TMP($J,ECDRG,0)="0^0^0"
+ ; add stats to record
+ S STATS=^TMP($J,ECDRG,0)
+ S ECCOUNT=$P(STATS,U),QTY=$P(STATS,U,2),COST=$P(STATS,U,3)
+ S ECCOUNT=ECCOUNT+1
+ S ECCOST=ECQTY*ECPRC
+ S ECQTY=ECQTY+QTY,ECCOST=ECCOST+COST
+ S ^TMP($J,ECDRG,0)=ECCOUNT_U_ECQTY_U_ECCOST
+ Q
+ ;
+EXIT S ECXERR=1 Q

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXDVSN.m

@@ -1 @@
-ECXDVSN ;ALB/JAP - Division selection utility ; 8/13/07 1:11pm
-        ;;3.0;DSS EXTRACTS;**8,105**;Dec 22, 1997;Build 70
-ADM(ECXDIV,ECXALL,ECXSTART,ECXEND,ECXERR)       ;division information for ADM extract audit report
-        ;selected inpatient divisions from medical center division file (#40.8)
-        ;   input
-        ;   ECXDIV = array of inpatient divisions selected (required)
-        ;            passed by reference array containing
-        ;            selected divisions;
-        ;   ECXALL = 1/0 (optional)
-        ;            1==> user wants all inpatient divisions OR
-        ;                 facility is non-divisional
-        ;            0==> user wants to select some divisions
-        ;            if ECXALL not defined, then assume 1
-        ;   ECXSTART = start date of date range (optional)
-        ;   ECXEND   = end date of date range (optional)
-        ;   ECXERR   = passed by reference for error return (required)
-        ;   output
-        ;   ECXDIV = array of divisions selected from file #40.8;
-        ;            if ECXALL=1, then array contains all divisions 
-        ;            if ECXALL=0, then array contains user-selected divisions
-        ;    ECXDIV(ien in file #40.8) = ien in file #4^name^station number^primary indicator^active indicator^dss id
-        ;   error CODE
-        ;   ECXERR   = 1, if input problem occurs
-        ;              0, otherwise
-        N OUT,DIC,X,Y,NM,ECXD,ECXIEN,ECXDIEN,ECXACT,ECXNAME,ECXNUM
-        S (OUT,ECXERR)=0
-        ;if start date or end date missing, then both default to today
-        I '$G(ECXSTART)!('$G(ECXEND)) S (ECXSTART,ECXEND)=DT
-        S:'$D(ECXALL) ECXALL=1 S:ECXALL="" ECXALL=1
-        I ECXALL=1 D
-        .S NM="" F  S NM=$O(^DG(40.8,"B",NM)) Q:NM=""  S ECXIEN=$O(^(NM,"")) D
-        ..Q:+$P(^DG(40.8,ECXIEN,0),U,3)=1
-        ..K Y S DIC="^DG(40.8,",DIC(0)="NZ",X=ECXIEN D ^DIC
-        ..Q:Y=-1
-        ..S ECXNAME=$P(Y(0),U,1),ECXNUM=$P(Y(0),U,2),ECXDIEN=$P(Y(0),U,7)
-        ..S ECXDIV(ECXIEN)=ECXDIEN_U_ECXNAME_U_ECXNUM
-        ..D ACTDIV(ECXIEN,ECXSTART,ECXEND,.ECXD,.ECXACT)
-        ..S ECXDIV(ECXIEN)=ECXDIV(ECXIEN)_U_ECXD_U_ECXACT
-        ..I $D(^ECX(727.3,ECXIEN)) D
-        ...S ECXDIV(ECXIEN)=ECXDIV(ECXIEN)_U_$P($G(^ECX(727.3,ECXIEN,0)),U,2)
-        I ECXALL=0 F  Q:OUT!ECXERR  D
-        .K Y S DIC="^DG(40.8,",DIC(0)="AEMQZ",DIC("S")="I $P(^(0),U,3)'=1"
-        .D ^DIC I $G(DUOUT)!($G(DTOUT)) S OUT=1,ECXERR=1 Q
-        .I Y=-1,X="" S OUT=1 Q
-        .S ECXIEN=+Y,ECXNAME=$P(Y(0),U,1),ECXNUM=$P(Y(0),U,2),ECXDIEN=$P(Y(0),U,7)
-        .S ECXDIV(ECXIEN)=ECXDIEN_U_ECXNAME_U_ECXNUM
-        .D ACTDIV(ECXIEN,ECXSTART,ECXEND,.ECXD,.ECXACT)
-        .S ECXDIV(ECXIEN)=ECXDIV(ECXIEN)_U_ECXD_U_ECXACT
-        .I $D(^ECX(727.3,ECXIEN)) D
-        ..S ECXDIV(ECXIEN)=ECXDIV(ECXIEN)_U_$P($G(^ECX(727.3,ECXIEN,0)),U,2)
-        .I 'ECXACT W !!,?5,"Please note: Division "_ECXNUM_" was not active during",!,?5,"             selected date range.",!
-        I ECXERR=1 K ECXDIV
-        I '$D(ECXDIV) S ECXERR=1
-        Q
-ACTDIV(ECXIEN,ECXSTART,ECXEND,ECXD,ECXACT)      ;determine if division active at anytime during date range
-        ;to be called by ADM^ECXDVSN
-        ;   input
-        ;   ECXIEN   = ien in file #40.8; required
-        ;   ECXSTART = start of date range; FM format; required
-        ;   ECXEND   = end of date range; FM format; required
-        ;   output
-        ;   ECXD   = 1/0; passed by reference
-        ;            1 indicates primary division
-        ;   ECXACT = 1/0; passed by reference
-        ;            returns 0, if division not active during date range;
-        ;            note: only start date and end date are checked; if division
-        ;                  inactive on both dates, then division assumed inactive
-        ;                  for entire date range
-        ;assume division active; set ecxact=1
-        S ECXACT=1
-        ;check if division active on start date or end date;
-        ;these dates are normally within the same month
-        F ECXDATE=ECXSTART,ECXEND D
-        .S DATE(ECXDATE)=$$SITE^VASITE(ECXDATE,ECXIEN)
-        .S ECXD=0
-        .I ECXIEN=$$PRIM^VASITE(ECXDATE) S ECXD=1
-        ;if not active on start date and not active on end date, reset ecxact=0
-        I DATE(ECXSTART)=-1,DATE(ECXEND)=-1 S ECXACT=0
-        Q
-MOV(ECXDIV,ECXALL,ECXSTART,ECXEND,ECXERR)       ;division information for MOV extract audit report 
-        ;selected divisions from medical center division file (#40.8)
-        ;   input
-        ;   (see ADM)
-        ;   output
-        ;   (see ADM)
-        D ADM^ECXDVSN(.ECXDIV,ECXALL,ECXSTART,ECXEND,.ECXERR)
-        Q
-PAS(ECXDIV,ECXALL,ECXERR)       ;setup division/site information for PAS extract audit report
-        ;   input
-        ;   ECXDIV = passed by reference array variable
-        ;   ECXALL = 1
-        ;   output
-        ;   ECXDIV = data for default division/site;
-        ;            ECXDIV(1)=ien in file #4^name^station number
-        ;            where the INSTITUTION file pointer is obtained from file #728
-        S ECXALL=1 D DEFAULT^ECXDVSN(.ECXDIV,ECXALL,.ECXERR)
-        Q
-TRT(ECXDIV,ECXALL,ECXERR)       ;setup division/site information for TRT extract audit report
-        ;   input
-        ;   ECXDIV = passed by reference array variable
-        ;   ECXALL = 1
-        ;   output
-        ;   ECXDIV = data for default division/site;
-        ;            ECXDIV(1)=ien in file #4^name^station number
-        ;            where the INSTITUTION file pointer is obtained from file #728
-        S ECXALL=1 D DEFAULT^ECXDVSN(.ECXDIV,ECXALL,.ECXERR)
-        Q
-DEFAULT(ECXDIV,ECXALL,ECXERR)   ;default division/site information for audit report
-        ;   input
-        ;   ECXDIV = passed by reference array variable
-        ;   ECXALL = 1
-        ;   output
-        ;   ECXDIV = data for default division/site;
-        ;            ECXDIV(1)=ien in file #4^name^station number
-        ;            where the INSTITUTION file pointer is obtained from file #728
-        N DIV,ECX
-        S ECXERR=0
-        S DIV=$P($G(^ECX(728,1,0)),U,1)
-        I DIV="" S ECXERR=1 Q
-        K ECX S DIC="^DIC(4,",DIQ(0)="I",DIQ="ECX",DA=DIV,DR=".01;99" D EN^DIQ1
-        I $D(ECX) S ECXDIV(1)=DIV_U_ECX(4,DIV,.01,"I")_U_ECX(4,DIV,99,"I")
-        I '$D(ECX) S ECXERR=1
-        I '$D(ECXDIV) S ECXERR=1
-        Q
-DEN(ECXDIV,ECXALL,ECXERR)       ;setup division/site information for DEN extract audit report
-        ;   input
-        ;   ECXDIV = passed by reference array variable (required)
-        ;   ECXALL = 0/1 (optional)
-        ;            '0' indicates user to select dental division;
-        ;            '1' indicates 'all' dental divisions or only one division
-        ;                exists in file #225; default is '1'
-        ;   output
-        ;   ECXDIV = data for dental division/site;
-        ;            ECXDIV(ien in file #225)=ien in file #4^name^station number
-        ;   ECXERR = 0/1
-        ;            if input problem, then '1' returned
-        N X,Y,DIC,DTOUT,DUOUT,DIRUT,OUT,ECXD,ECXIEN
-        S:'$D(ECXALL) ECXALL=1 S:ECXALL="" ECXALL=1
-        S ECXERR=0,ECXD=""
-        ;if ecxall=1, then all dental divisions/sites
-        I ECXALL=1 D
-        .F  S ECXD=$O(^DENT(225,"B",ECXD)) Q:ECXD=""  S ECXIEN=$O(^(ECXD,"")) D
-        ..S $P(ECXDIV(ECXIEN),U,3)=ECXD S DIC="^DIC(4,",DIC(0)="MX",X=ECXD D ^DIC
-        ..S:+Y>0 ECXDIV(ECXIEN)=Y S:+Y=-1 ECXDIV(ECXIEN)=U
-        ..S ECXDIV(ECXIEN)=ECXDIV(ECXIEN)_U_ECXD
-        ;if ecxall=0, user selects some/all dental divisions/sites
-        I ECXALL=0 S OUT=0 D
-        .F  Q:OUT!ECXERR  D
-        ..S DIC="^DENT(225,",DIC(0)="AEMQ" K X,Y D ^DIC
-        ..I $G(DUOUT)!($G(DTOUT)) S OUT=1,ECXERR=1 Q
-        ..I Y=-1,X="" S OUT=1 Q
-        ..S ECXIEN=+Y,ECXD=$P(Y,U,2) K X,Y
-        ..S DIC="^DIC(4,",DIC(0)="MX",X=ECXD D ^DIC
-        ..S:+Y>0 ECXDIV(ECXIEN)=Y S:+Y=-1 ECXDIV(ECXIEN)=U
-        ..S ECXDIV(ECXIEN)=ECXDIV(ECXIEN)_U_ECXD
-        I ECXERR=1 K ECXDIV
-        I '$D(ECXDIV) S ECXERR=1
-        Q
-ECS(ECXDIV,ECXALL,ECXERR)       ;setup division/location information for ECS extract audit report
-        ;   input
-        ;   ECXDIV = passed by reference array variable (required)
-        ;   ECXALL = 0/1 (optional)
-        ;            '0' indicates user to select EC location(s);
-        ;            '1' indicates 'all' locations or only one location
-        ;                exists in file #4 "LOC" index;
-        ;            default is '1'
-        ;   output
-        ;   ECXDIV = data for EC location;
-        ;            ECXDIV(ien in file #4)=ien in file #4^name^station number
-        ;            where the INSTITUTION file pointer is obtained from 
-        ;            "LOC" index in file #4
-        ;   ECXERR = 0/1
-        ;            if input problem, then '1' returned
-        ;
-        N X,Y,I,DIC,DIR,DIRUT,DTOUT,DUOUT,NM,OUT,ECXD,ECXIEN,ECXLOC
-        S:'$D(ECXALL) ECXALL=1 S:ECXALL="" ECXALL=1
-        S ECXERR=0,ECXD="",I=0
-        ;get all available ec locations in ecxloc array
-        F  S ECXD=$O(^DIC(4,"LOC",ECXD)) Q:ECXD=""  S I=I+1,ECXIEN=$O(^(ECXD,"")),ECXLOC(I)=ECXD_U_ECXIEN_U_$P($G(^DIC(4,ECXIEN,99)),U,1)
-        ;if ecxall=1, then all ec locations
-        I ECXALL=1 S I="" D  Q
-        .F  S I=$O(ECXLOC(I)) Q:I=""  D
-        ..S ECXIEN=$P(ECXLOC(I),U,2)
-        ..S ECXDIV(ECXIEN)=ECXIEN_U_$P(ECXLOC(I),U,1)_U_$P(ECXLOC(I),U,3)
-        I ECXALL=0 S OUT=0,I=0 D
-        .W !!,"Event Capture Locations:",! S I=0,DIR(0)="SXO^"
-        .;spaces are embedded in dir(0) to prevent user from selecting by alpha characters in name
-        .F  S I=$O(ECXLOC(I)) Q:I=""  S NM=$P(ECXLOC(I),U,1) W !,?10,I_"  ",NM S DIR(0)=DIR(0)_I_":"_"-   "_NM_";"
-        .W !
-        .F  Q:OUT!ECXERR  D
-        ..S DIR("A")="Select Event Capture Location",DIR("S")="I +Y=Y"
-        ..D ^DIR
-        ..I $G(DTOUT)!($G(DUOUT)) S ECXERR=1 Q
-        ..I X="" D  Q
-        ...I '$D(ECXDIV) W !!,"No Location selected...exiting.",! S OUT=1 Q
-        ...W !!,"You have selected the following Location(s):",!
-        ...S I=0 F  S I=$O(ECXDIV(I)) Q:I=""  W !,?10,$P(ECXDIV(I),U,2)_" ("_$P(ECXDIV(I),U,3)_")"
-        ...W ! K X,Y,DIR S DIR(0)="Y",DIR("A")="Is that ok",DIR("B")="YES" D ^DIR
-        ...I $D(DIRUT) S ECXERR=1
-        ...I Y=0 S ECXERR=1
-        ...S OUT=1
-        ..S ECXIEN=$P(ECXLOC(X),U,2)
-        ..S ECXDIV(ECXIEN)=ECXIEN_U_$P(ECXLOC(X),U,1)_U_$P(ECXLOC(X),U,3)
-        ;exit
-        I ECXERR=1 K ECXDIV
-        I '$D(ECXDIV) S ECXERR=1
-        Q
-NUT()   ; Set Divisions into screen array (prompt is one/many/all)
-        ;Input  : SCRNARR - Screen array full global reference
-        ;Output : 1 = OK     0 = User abort/timeout
-        ;         @SCRNARR@("DIVISION") = User pick all divisions ?
-        ;           1 = Yes (all)     0 = No
-        ;         @SCRNARR@("DIVISION",PtrDiv) = Division name
-        ;Note   : @SCRNARR@("DIVISION") is initialized (KILLed) on input
-        ;       : @SCRNARR@("DIVISION",PtrDiv) is only set when the user
-        ;         picked individual divisions (i.e. didn't pick all)
-        ;
-        ;Declare variables
-        N VAUTD,Y,SCANARR
-        ;Get division selection
-        S DIC="^DIC(4,"
-        S VAUTSTR="PATIENT DIVISION"
-        S VAUTVB="SCANARR"
-        S VAUTNI=2
-        D FIRST^VAUTOMA
-        I Y<0 Q 1
-        M @SCRNARR@("DIVISION")=SCANARR
-        Q 0
+ECXDVSN ;ALB/JAP - Division selection utility ;Sep 29, 1997
+ ;;3.0;DSS EXTRACTS;**8**;Dec 22, 1997
+ ;
+ADM(ECXDIV,ECXALL,ECXSTART,ECXEND,ECXERR) ;division information for ADM extract audit report
+ ;selected inpatient divisions from medical center division file (#40.8)
+ ;   input
+ ;   ECXDIV = array of inpatient divisions selected (required)
+ ;            passed by reference array containing
+ ;            selected divisions;
+ ;   ECXALL = 1/0 (optional)
+ ;            1==> user wants all inpatient divisions OR
+ ;                 facility is non-divisional
+ ;            0==> user wants to select some divisions
+ ;            if ECXALL not defined, then assume 1
+ ;   ECXSTART = start date of date range (optional)
+ ;   ECXEND   = end date of date range (optional)
+ ;   ECXERR   = passed by reference for error return (required)
+ ;   output
+ ;   ECXDIV = array of divisions selected from file #40.8;
+ ;            if ECXALL=1, then array contains all divisions 
+ ;            if ECXALL=0, then array contains user-selected divisions
+ ;    ECXDIV(ien in file #40.8) = ien in file #4^name^station number^primary indicator^active indicator^dss id
+ ;   error CODE
+ ;   ECXERR   = 1, if input problem occurs
+ ;              0, otherwise
+ ;
+ N OUT,DIC,X,Y,NM,ECXD,ECXIEN,ECXDIEN,ECXACT,ECXNAME,ECXNUM
+ S (OUT,ECXERR)=0
+ ;if start date or end date missing, then both default to today
+ I '$G(ECXSTART)!('$G(ECXEND)) S (ECXSTART,ECXEND)=DT
+ S:'$D(ECXALL) ECXALL=1 S:ECXALL="" ECXALL=1
+ I ECXALL=1 D
+ .S NM="" F  S NM=$O(^DG(40.8,"B",NM)) Q:NM=""  S ECXIEN=$O(^(NM,"")) D
+ ..Q:+$P(^DG(40.8,ECXIEN,0),U,3)=1
+ ..K Y S DIC="^DG(40.8,",DIC(0)="NZ",X=ECXIEN D ^DIC
+ ..Q:Y=-1
+ ..S ECXNAME=$P(Y(0),U,1),ECXNUM=$P(Y(0),U,2),ECXDIEN=$P(Y(0),U,7)
+ ..S ECXDIV(ECXIEN)=ECXDIEN_U_ECXNAME_U_ECXNUM
+ ..D ACTDIV(ECXIEN,ECXSTART,ECXEND,.ECXD,.ECXACT)
+ ..S ECXDIV(ECXIEN)=ECXDIV(ECXIEN)_U_ECXD_U_ECXACT
+ ..I $D(^ECX(727.3,ECXIEN)) D
+ ...S ECXDIV(ECXIEN)=ECXDIV(ECXIEN)_U_$P($G(^ECX(727.3,ECXIEN,0)),U,2)
+ I ECXALL=0 F  Q:OUT!ECXERR  D
+ .K Y S DIC="^DG(40.8,",DIC(0)="AEMQZ",DIC("S")="I $P(^(0),U,3)'=1"
+ .D ^DIC I $G(DUOUT)!($G(DTOUT)) S OUT=1,ECXERR=1 Q
+ .I Y=-1,X="" S OUT=1 Q
+ .S ECXIEN=+Y,ECXNAME=$P(Y(0),U,1),ECXNUM=$P(Y(0),U,2),ECXDIEN=$P(Y(0),U,7)
+ .S ECXDIV(ECXIEN)=ECXDIEN_U_ECXNAME_U_ECXNUM
+ .D ACTDIV(ECXIEN,ECXSTART,ECXEND,.ECXD,.ECXACT)
+ .S ECXDIV(ECXIEN)=ECXDIV(ECXIEN)_U_ECXD_U_ECXACT
+ .I $D(^ECX(727.3,ECXIEN)) D
+ ..S ECXDIV(ECXIEN)=ECXDIV(ECXIEN)_U_$P($G(^ECX(727.3,ECXIEN,0)),U,2)
+ .I 'ECXACT W !!,?5,"Please note: Division "_ECXNUM_" was not active during",!,?5,"             selected date range.",!
+ I ECXERR=1 K ECXDIV
+ I '$D(ECXDIV) S ECXERR=1
+ Q
+ ;
+ACTDIV(ECXIEN,ECXSTART,ECXEND,ECXD,ECXACT) ;determine if division active at anytime during date range
+ ;to be called by ADM^ECXDVSN
+ ;   input
+ ;   ECXIEN   = ien in file #40.8; required
+ ;   ECXSTART = start of date range; FM format; required
+ ;   ECXEND   = end of date range; FM format; required
+ ;   output
+ ;   ECXD   = 1/0; passed by reference
+ ;            1 indicates primary division
+ ;   ECXACT = 1/0; passed by reference
+ ;            returns 0, if division not active during date range;
+ ;            note: only start date and end date are checked; if division
+ ;                  inactive on both dates, then division assumed inactive
+ ;                  for entire date range
+ ;assume division active; set ecxact=1
+ S ECXACT=1
+ ;check if division active on start date or end date;
+ ;these dates are normally within the same month
+ F ECXDATE=ECXSTART,ECXEND D
+ .S DATE(ECXDATE)=$$SITE^VASITE(ECXDATE,ECXIEN)
+ .S ECXD=0
+ .I ECXIEN=$$PRIM^VASITE(ECXDATE) S ECXD=1
+ ;if not active on start date and not active on end date, reset ecxact=0
+ I DATE(ECXSTART)=-1,DATE(ECXEND)=-1 S ECXACT=0
+ Q
+ ;
+MOV(ECXDIV,ECXALL,ECXSTART,ECXEND,ECXERR) ;division information for MOV extract audit report 
+ ;selected divisions from medical center division file (#40.8)
+ ;   input
+ ;   (see ADM)
+ ;   output
+ ;   (see ADM)
+ ;
+ D ADM^ECXDVSN(.ECXDIV,ECXALL,ECXSTART,ECXEND,.ECXERR)
+ Q
+ ;
+PAS(ECXDIV,ECXALL,ECXERR) ;setup division/site information for PAS extract audit report
+ ;   input
+ ;   ECXDIV = passed by reference array variable
+ ;   ECXALL = 1
+ ;   output
+ ;   ECXDIV = data for default division/site;
+ ;            ECXDIV(1)=ien in file #4^name^station number
+ ;            where the INSTITUTION file pointer is obtained from file #728
+ ;
+ S ECXALL=1 D DEFAULT^ECXDVSN(.ECXDIV,ECXALL,.ECXERR)
+ Q
+ ;
+TRT(ECXDIV,ECXALL,ECXERR) ;setup division/site information for TRT extract audit report
+ ;   input
+ ;   ECXDIV = passed by reference array variable
+ ;   ECXALL = 1
+ ;   output
+ ;   ECXDIV = data for default division/site;
+ ;            ECXDIV(1)=ien in file #4^name^station number
+ ;            where the INSTITUTION file pointer is obtained from file #728
+ ;
+ S ECXALL=1 D DEFAULT^ECXDVSN(.ECXDIV,ECXALL,.ECXERR)
+ Q
+ ;
+DEFAULT(ECXDIV,ECXALL,ECXERR) ;default division/site information for audit report
+ ;   input
+ ;   ECXDIV = passed by reference array variable
+ ;   ECXALL = 1
+ ;   output
+ ;   ECXDIV = data for default division/site;
+ ;            ECXDIV(1)=ien in file #4^name^station number
+ ;            where the INSTITUTION file pointer is obtained from file #728
+ ;
+ N DIV,ECX
+ S ECXERR=0
+ S DIV=$P($G(^ECX(728,1,0)),U,1)
+ I DIV="" S ECXERR=1 Q
+ K ECX S DIC="^DIC(4,",DIQ(0)="I",DIQ="ECX",DA=DIV,DR=".01;99" D EN^DIQ1
+ I $D(ECX) S ECXDIV(1)=DIV_U_ECX(4,DIV,.01,"I")_U_ECX(4,DIV,99,"I")
+ I '$D(ECX) S ECXERR=1
+ I '$D(ECXDIV) S ECXERR=1
+ Q
+ ;
+DEN(ECXDIV,ECXALL,ECXERR) ;setup division/site information for DEN extract audit report
+ ;   input
+ ;   ECXDIV = passed by reference array variable (required)
+ ;   ECXALL = 0/1 (optional)
+ ;            '0' indicates user to select dental division;
+ ;            '1' indicates 'all' dental divisions or only one division
+ ;                exists in file #225; default is '1'
+ ;   output
+ ;   ECXDIV = data for dental division/site;
+ ;            ECXDIV(ien in file #225)=ien in file #4^name^station number
+ ;   ECXERR = 0/1
+ ;            if input problem, then '1' returned
+ N X,Y,DIC,DTOUT,DUOUT,DIRUT,OUT,ECXD,ECXIEN
+ S:'$D(ECXALL) ECXALL=1 S:ECXALL="" ECXALL=1
+ S ECXERR=0,ECXD=""
+ ;if ecxall=1, then all dental divisions/sites
+ I ECXALL=1 D
+ .F  S ECXD=$O(^DENT(225,"B",ECXD)) Q:ECXD=""  S ECXIEN=$O(^(ECXD,"")) D
+ ..S $P(ECXDIV(ECXIEN),U,3)=ECXD S DIC="^DIC(4,",DIC(0)="MX",X=ECXD D ^DIC
+ ..S:+Y>0 ECXDIV(ECXIEN)=Y S:+Y=-1 ECXDIV(ECXIEN)=U
+ ..S ECXDIV(ECXIEN)=ECXDIV(ECXIEN)_U_ECXD
+ ;if ecxall=0, user selects some/all dental divisions/sites
+ I ECXALL=0 S OUT=0 D
+ .F  Q:OUT!ECXERR  D
+ ..S DIC="^DENT(225,",DIC(0)="AEMQ" K X,Y D ^DIC
+ ..I $G(DUOUT)!($G(DTOUT)) S OUT=1,ECXERR=1 Q
+ ..I Y=-1,X="" S OUT=1 Q
+ ..S ECXIEN=+Y,ECXD=$P(Y,U,2) K X,Y
+ ..S DIC="^DIC(4,",DIC(0)="MX",X=ECXD D ^DIC
+ ..S:+Y>0 ECXDIV(ECXIEN)=Y S:+Y=-1 ECXDIV(ECXIEN)=U
+ ..S ECXDIV(ECXIEN)=ECXDIV(ECXIEN)_U_ECXD
+ I ECXERR=1 K ECXDIV
+ I '$D(ECXDIV) S ECXERR=1
+ Q
+ ;
+ECS(ECXDIV,ECXALL,ECXERR) ;setup division/location information for ECS extract audit report
+ ;   input
+ ;   ECXDIV = passed by reference array variable (required)
+ ;   ECXALL = 0/1 (optional)
+ ;            '0' indicates user to select EC location(s);
+ ;            '1' indicates 'all' locations or only one location
+ ;                exists in file #4 "LOC" index;
+ ;            default is '1'
+ ;   output
+ ;   ECXDIV = data for EC location;
+ ;            ECXDIV(ien in file #4)=ien in file #4^name^station number
+ ;            where the INSTITUTION file pointer is obtained from 
+ ;            "LOC" index in file #4
+ ;   ECXERR = 0/1
+ ;            if input problem, then '1' returned
+ ;
+ N X,Y,I,DIC,DIR,DIRUT,DTOUT,DUOUT,NM,OUT,ECXD,ECXIEN,ECXLOC
+ S:'$D(ECXALL) ECXALL=1 S:ECXALL="" ECXALL=1
+ S ECXERR=0,ECXD="",I=0
+ ;get all available ec locations in ecxloc array
+ F  S ECXD=$O(^DIC(4,"LOC",ECXD)) Q:ECXD=""  S I=I+1,ECXIEN=$O(^(ECXD,"")),ECXLOC(I)=ECXD_U_ECXIEN_U_$P($G(^DIC(4,ECXIEN,99)),U,1)
+ ;if ecxall=1, then all ec locations
+ I ECXALL=1 S I="" D  Q
+ .F  S I=$O(ECXLOC(I)) Q:I=""  D
+ ..S ECXIEN=$P(ECXLOC(I),U,2)
+ ..S ECXDIV(ECXIEN)=ECXIEN_U_$P(ECXLOC(I),U,1)_U_$P(ECXLOC(I),U,3)
+ I ECXALL=0 S OUT=0,I=0 D
+ .W !!,"Event Capture Locations:",! S I=0,DIR(0)="SXO^"
+ .;spaces are embedded in dir(0) to prevent user from selecting by alpha characters in name
+ .F  S I=$O(ECXLOC(I)) Q:I=""  S NM=$P(ECXLOC(I),U,1) W !,?10,I_"  ",NM S DIR(0)=DIR(0)_I_":"_"-   "_NM_";"
+ .W !
+ .F  Q:OUT!ECXERR  D
+ ..S DIR("A")="Select Event Capture Location",DIR("S")="I +Y=Y"
+ ..D ^DIR
+ ..I $G(DTOUT)!($G(DUOUT)) S ECXERR=1 Q
+ ..I X="" D  Q
+ ...I '$D(ECXDIV) W !!,"No Location selected...exiting.",! S OUT=1 Q
+ ...W !!,"You have selected the following Location(s):",!
+ ...S I=0 F  S I=$O(ECXDIV(I)) Q:I=""  W !,?10,$P(ECXDIV(I),U,2)_" ("_$P(ECXDIV(I),U,3)_")"
+ ...W ! K X,Y,DIR S DIR(0)="Y",DIR("A")="Is that ok",DIR("B")="YES" D ^DIR
+ ...I $D(DIRUT) S ECXERR=1
+ ...I Y=0 S ECXERR=1
+ ...S OUT=1
+ ..S ECXIEN=$P(ECXLOC(X),U,2)
+ ..S ECXDIV(ECXIEN)=ECXIEN_U_$P(ECXLOC(X),U,1)_U_$P(ECXLOC(X),U,3)
+ ;exit
+ I ECXERR=1 K ECXDIV
+ I '$D(ECXDIV) S ECXERR=1
+ Q

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXDVSN1.m

@@ -1 @@
-ECXDVSN1        ;ALB/JAP - Division selection utility (cont.) ; 3/30/07 7:56am
-        ;;3.0;DSS EXTRACTS;**8,105**;Dec 22, 1997;Build 70
-        ;
-ECQ(ECXDIV,ECXALL,ECXERR)       ;setup division/site information for QSR extract audit report
-        ;   input
-        ;   ECXDIV = passed by reference array variable (required)
-        ;   ECXALL = 0/1 (optional)
-        ;            '0' indicates user to select QUASAR site/division;
-        ;            '1' indicates 'all' sites/divisions or only one site/division
-        ;                exists in file #509850.8; currently only one site is allowed
-        ;                to be defined;
-        ;            default is '1'
-        ;   output
-        ;   ECXDIV = data for QUASAR site/division;
-        ;            ECXDIV(ien in file #4)=ien in file #509850.8^name^station number
-        ;   ECXERR = 0/1
-        ;            if input problem, then '1' returned
-        ;
-        N X,Y,DIC,OUT,ECX,ECXD,ECXIEN
-        S:'$D(ECXALL) ECXALL=1 S:ECXALL="" ECXALL=1
-        ;currently, only ONE site may be defined in file #509850.8
-        S:ECXALL=0 ECXALL=1
-        S ECXERR=0,ECXD=""
-        ;if ecxall=1, then all QUASAR sites/divisions; but there's only one
-        I ECXALL=1 D
-        .F  S ECXD=$O(^ACK(509850.8,"B",ECXD)) Q:ECXD=""  S ECXIEN=$O(^(ECXD,"")) D
-        ..K ECX S DIC="^DIC(4,",DIQ(0)="I",DIQ="ECX",DA=ECXD,DR=".01;99" D EN^DIQ1
-        ..I $D(ECX) S ECXDIV(ECXD)=ECXIEN_U_ECX(4,ECXD,.01,"I")_U_ECX(4,ECXD,99,"I")
-        ..I '$D(ECX) S ECXERR=1
-        I ECXERR=1 K ECXDIV
-        I '$D(ECXDIV) S ECXERR=1
-        Q
-        ;
-LAB(ECXACC,ECXALL,ECXERR)       ;setup accession area information for LAB extract audit report
-        ;   input
-        ;   ECXACC = passed by reference array variable (required)
-        ;   ECXALL = 0/1 (optional)
-        ;            '0' indicates user to select Accession Area(s);
-        ;            '1' indicates 'all' Accession Areas are selected
-        ;            default is '1'
-        ;   output
-        ;   ECXACC = data for Accession Area(s);
-        ;            ECXACC(ien in file #68)=name^abbreviation
-        ;   ECXERR = 0/1
-        ;            if input problem, then '1' returned
-        ;
-        N X,Y,DIC,DIQ,DA,DR,DTOUT,DUOUT,DIRUT,OUT,ECX,ECXA,ECXIEN
-        S:'$D(ECXALL) ECXALL=1 S:ECXALL="" ECXALL=1
-        S ECXERR=0,ECXA=""
-        ;if ecxall=1, then all accession areas are selected
-        I ECXALL=1 D
-        .;^LRO(68,"B",xxx,ien)=1 indicates a synonym; skip synonyms
-        .F  S ECXA=$O(^LRO(68,"B",ECXA)) Q:ECXA=""  S ECXIEN=$O(^(ECXA,"")) D
-        ..Q:^LRO(68,"B",ECXA,ECXIEN)=1
-        ..K ECX S DIC="^LRO(68,",DR=".01;.09",DIQ="ECX",DA=ECXIEN D EN^DIQ1
-        ..Q:'$D(ECX)
-        ..;acc. areas with ZZ in name indicates no longer used
-        ..Q:$E(ECX(68,ECXIEN,.01),1,2)="ZZ"
-        ..S ECXACC(ECXIEN)=ECX(68,ECXIEN,.01)_U_ECX(68,ECXIEN,.09)
-        ;if ecxall=0, user selects some/all acc. areas
-        ;allow user to choose "ZZ"'d acc. area even though it may currently be inactive
-        I ECXALL=0 S OUT=0 D
-        .F  Q:OUT!ECXERR  D
-        ..S DIC="^LRO(68,",DIC(0)="AEMQZ" K X,Y D ^DIC
-        ..I $G(DUOUT)!($G(DTOUT)) S OUT=1,ECXERR=1 Q
-        ..I Y=-1,X="" S OUT=1 Q
-        ..S ECXACC(+Y)=$P(Y(0),U,1)_U_$P(Y(0),U,11)
-        I ECXERR=1 K ECXACC
-        I '$D(ECXACC) S ECXERR=1
-        Q
-        ;
-NUR(ECXDIV,ECXALL,ECXERR)       ;setup accession area information for LAB extract audit report
-        ;   input
-        ;   ECXDIV = passed by reference array variable (required)
-        ;   ECXALL = 0/1 (optional)
-        ;            '0' indicates user to select nursing location(s)/division(s);
-        ;            '1' indicates 'all' nursing locations and medical center divisions 
-        ;                are selected or facility is non-divisional;
-        ;            default is '1'
-        ;   output
-        ;   ECXDIV = data for nursing location(s) and medical center division(s);
-        ;            ECXDIV("D",ien in file #40.8)=ien in file #4^name^station number
-        ;            ECXDIV(ien in file #211.4,ien in file #40.8)=ien in file #44
-        ;   ECXERR = 0/1
-        ;            if input problem, then '1' returned
-        ;
-        ;N X,Y,DIC,DIQ,DA,OUT,ECX,ECXLOC,ECXSC,ECXDIEN,ECXNLIEN,ECXNLNM,ECXPRIME
-        S:'$D(ECXALL) ECXALL=1 S:ECXALL="" ECXALL=1
-        S (ECXERR,OUT)=0,ECXSC=""
-        ;get ien in file #40.8 of primary division
-        S ECXPRIME=$$PRIM^VASITE(DT)
-        ;associate nursing locations with medical center divisions
-        F  S ECXSC=$O(^NURSF(211.4,"B",ECXSC)) Q:ECXSC=""  S ECXNLIEN="" F  S ECXNLIEN=$O(^NURSF(211.4,"B",ECXSC,ECXNLIEN)) Q:ECXNLIEN=""  D
-        .K ECX
-        .S ECXDIEN=0,ECXNLNM="",DIC="^SC(",DIQ(0)="I",DIQ="ECX",DA=ECXSC,DR=".01;3.5" D EN^DIQ1
-        .;if the 15th piece is null or y=-1 then ecxdien=primary division as default
-        .I $D(ECX) S ECXDIEN=+ECX(44,ECXSC,3.5,"I"),ECXNLNM=ECX(44,ECXSC,.01,"I")
-        .S:ECXDIEN=0 ECXDIEN=ECXPRIME
-        .S ECXLOC(ECXDIEN)="",ECXLOC(ECXDIEN,ECXNLIEN)=ECXSC_U_ECXNLNM
-        ;
-        ;if ecxall=1 don't prompt; setup all nursing locations and divisions incl. those w/o division
-        I ECXALL=1 S ECXDIEN="" D
-        .F  S ECXDIEN=$O(ECXLOC(ECXDIEN)) Q:ECXDIEN=""  D
-        ..S DIC="^DG(40.8,",DIC(0)="NXZ",X=ECXDIEN D ^DIC I +Y>0 D
-        ...S ECXDIV("D",ECXDIEN)=$P(Y(0),U,7)_U_$P(Y(0),U,1)_U_$P(Y(0),U,2),ECXNLIEN=""
-        ...F  S ECXNLIEN=$O(ECXLOC(ECXDIEN,ECXNLIEN)) Q:ECXNLIEN=""  S ECXDIV(ECXNLIEN,ECXDIEN)=ECXLOC(ECXDIEN,ECXNLIEN)
-        ;
-        ;if ecxall=0 let user select division(s)
-        I ECXALL=0 F  Q:OUT!ECXERR  D
-        .S DIC="^DG(40.8,",DIC(0)="AEMQZ",DIC("S")="I $P(^(0),U,3)'=1"
-        .D ^DIC I $G(DUOUT)!($G(DTOUT)) S OUT=1,ECXERR=1 Q
-        .I Y=-1,X="" S OUT=1 Q
-        .S ECXDIEN=+Y,NM=$P(Y,U,2)
-        .I '$D(ECXLOC(ECXDIEN)) D  Q
-        ..W !!,?5,"Division "_NM_" not associated with Nursing Locations.",!,?5,"Try again...",!
-        .S ECXDIV("D",ECXDIEN)=$P(Y(0),U,7)_U_$P(Y(0),U,1)_U_$P(Y(0),U,2),ECXNLIEN=""
-        .F  S ECXNLIEN=$O(ECXLOC(ECXDIEN,ECXNLIEN)) Q:ECXNLIEN=""  S ECXDIV(ECXNLIEN,ECXDIEN)=ECXLOC(ECXDIEN,ECXNLIEN)
-        ;in case of user up-arrow out or timeout, make sure nothing returned in ecxdiv
-        I ECXERR=1 K ECXDIV
-        I '$D(ECXDIV) S ECXERR=1
-        Q
-        ;
-PRE(ECXDIV,ECXALL,ECXERR)       ;setup site information for PRE extract audit report
-        ;   input
-        ;   ECXDIV = passed by reference array variable (required)
-        ;   ECXALL = 0/1 (optional)
-        ;            '0' indicates user to select Pharmacy site(s);
-        ;            '1' indicates 'all' sites are selected
-        ;            default is '1'
-        ;   output
-        ;   ECXDIV = data for Pharmacy site(s);
-        ;            ECXDIV(ien in file #59)=IEN in file #59^name^site number^IEN in file #4
-        ;   ECXERR = 0/1
-        ;            if input problem, then '1' returned
-        ;
-        N X,Y,DIC,DIQ,DA,OUT,ECXARR,ECXP,ECXIEN,ARRAY
-        S:'$D(ECXALL) ECXALL=1 S:ECXALL="" ECXALL=1
-        S ECXERR=0,ECXP="",ARRAY="^TMP($J,""ECXDSS"")"
-        K @ARRAY
-        ;if ecxall=1, then all pharmacy sites are selected or there's only one
-        I ECXALL=1 S ECXP="" D
-        .D PSS^PSO59(,"??","ECXDSS")
-        .F  S ECXP=$O(@ARRAY@("B",ECXP)) Q:ECXP=""  S ECXIEN=$O(^(ECXP,0)) Q:'ECXIEN  Q:'$D(^(ECXIEN))  D
-        ..S ECXDIV(ECXIEN)=ECXIEN_U_@ARRAY@(ECXIEN,.01)_U_^(.06)_U_^(100)
-        ;if ecxall=0, then user selects pharmacy site(s)
-        I ECXALL=0 S OUT=0 D
-        .F  Q:OUT!ECXERR  D
-        ..N DIC,X,Y,DUOUT,DTOUT
-        ..S DIC="^PS(59,",DIC(0)="AEMQZ"
-        ..D DIC^PSODI(59,.DIC,.X)
-        ..I $G(DUOUT)!($G(DTOUT)) S OUT=1,ECXERR=1 Q
-        ..I Y=-1,X="" S OUT=1 Q
-        ..D PSS^PSO59(+Y,,"ECXDSS")
-        ..Q:'$D(@ARRAY)
-        ..S ECXDIV(ECXIEN)=ECXIEN_U_@ARRAY@(ECXIEN,.01)_U_^(.06)_U_^(100)
-        ;
-        I ECXERR=1 K ECXDIV
-        I '$D(ECXDIV) S ECXERR=1
-        Q
+ECXDVSN1 ;ALB/JAP - Division selection utility (cont.) ;Sep 30, 1997
+ ;;3.0;DSS EXTRACTS;**8**;Dec 22, 1997
+ ;
+ECQ(ECXDIV,ECXALL,ECXERR) ;setup division/site information for QSR extract audit report
+ ;   input
+ ;   ECXDIV = passed by reference array variable (required)
+ ;   ECXALL = 0/1 (optional)
+ ;            '0' indicates user to select QUASAR site/division;
+ ;            '1' indicates 'all' sites/divisions or only one site/division
+ ;                exists in file #509850.8; currently only one site is allowed
+ ;                to be defined;
+ ;            default is '1'
+ ;   output
+ ;   ECXDIV = data for QUASAR site/division;
+ ;            ECXDIV(ien in file #4)=ien in file #509850.8^name^station number
+ ;   ECXERR = 0/1
+ ;            if input problem, then '1' returned
+ ;
+ N X,Y,DIC,OUT,ECX,ECXD,ECXIEN
+ S:'$D(ECXALL) ECXALL=1 S:ECXALL="" ECXALL=1
+ ;currently, only ONE site may be defined in file #509850.8
+ S:ECXALL=0 ECXALL=1
+ S ECXERR=0,ECXD=""
+ ;if ecxall=1, then all QUASAR sites/divisions; but there's only one
+ I ECXALL=1 D
+ .F  S ECXD=$O(^ACK(509850.8,"B",ECXD)) Q:ECXD=""  S ECXIEN=$O(^(ECXD,"")) D
+ ..K ECX S DIC="^DIC(4,",DIQ(0)="I",DIQ="ECX",DA=ECXD,DR=".01;99" D EN^DIQ1
+ ..I $D(ECX) S ECXDIV(ECXD)=ECXIEN_U_ECX(4,ECXD,.01,"I")_U_ECX(4,ECXD,99,"I")
+ ..I '$D(ECX) S ECXERR=1
+ I ECXERR=1 K ECXDIV
+ I '$D(ECXDIV) S ECXERR=1
+ Q
+ ;
+LAB(ECXACC,ECXALL,ECXERR) ;setup accession area information for LAB extract audit report
+ ;   input
+ ;   ECXACC = passed by reference array variable (required)
+ ;   ECXALL = 0/1 (optional)
+ ;            '0' indicates user to select Accession Area(s);
+ ;            '1' indicates 'all' Accession Areas are selected
+ ;            default is '1'
+ ;   output
+ ;   ECXACC = data for Accession Area(s);
+ ;            ECXACC(ien in file #68)=name^abbreviation
+ ;   ECXERR = 0/1
+ ;            if input problem, then '1' returned
+ ;
+ N X,Y,DIC,DIQ,DA,DR,DTOUT,DUOUT,DIRUT,OUT,ECX,ECXA,ECXIEN
+ S:'$D(ECXALL) ECXALL=1 S:ECXALL="" ECXALL=1
+ S ECXERR=0,ECXA=""
+ ;if ecxall=1, then all accession areas are selected
+ I ECXALL=1 D
+ .;^LRO(68,"B",xxx,ien)=1 indicates a synonym; skip synonyms
+ .F  S ECXA=$O(^LRO(68,"B",ECXA)) Q:ECXA=""  S ECXIEN=$O(^(ECXA,"")) D
+ ..Q:^LRO(68,"B",ECXA,ECXIEN)=1
+ ..K ECX S DIC="^LRO(68,",DR=".01;.09",DIQ="ECX",DA=ECXIEN D EN^DIQ1
+ ..Q:'$D(ECX)
+ ..;acc. areas with ZZ in name indicates no longer used
+ ..Q:$E(ECX(68,ECXIEN,.01),1,2)="ZZ"
+ ..S ECXACC(ECXIEN)=ECX(68,ECXIEN,.01)_U_ECX(68,ECXIEN,.09)
+ ;if ecxall=0, user selects some/all acc. areas
+ ;allow user to choose "ZZ"'d acc. area even though it may currently be inactive
+ I ECXALL=0 S OUT=0 D
+ .F  Q:OUT!ECXERR  D
+ ..S DIC="^LRO(68,",DIC(0)="AEMQZ" K X,Y D ^DIC
+ ..I $G(DUOUT)!($G(DTOUT)) S OUT=1,ECXERR=1 Q
+ ..I Y=-1,X="" S OUT=1 Q
+ ..S ECXACC(+Y)=$P(Y(0),U,1)_U_$P(Y(0),U,11)
+ I ECXERR=1 K ECXACC
+ I '$D(ECXACC) S ECXERR=1
+ Q
+ ;
+NUR(ECXDIV,ECXALL,ECXERR) ;setup accession area information for LAB extract audit report
+ ;   input
+ ;   ECXDIV = passed by reference array variable (required)
+ ;   ECXALL = 0/1 (optional)
+ ;            '0' indicates user to select nursing location(s)/division(s);
+ ;            '1' indicates 'all' nursing locations and medical center divisions 
+ ;                are selected or facility is non-divisional;
+ ;            default is '1'
+ ;   output
+ ;   ECXDIV = data for nursing location(s) and medical center division(s);
+ ;            ECXDIV("D",ien in file #40.8)=ien in file #4^name^station number
+ ;            ECXDIV(ien in file #211.4,ien in file #40.8)=ien in file #44
+ ;   ECXERR = 0/1
+ ;            if input problem, then '1' returned
+ ;
+ ;N X,Y,DIC,DIQ,DA,OUT,ECX,ECXLOC,ECXSC,ECXDIEN,ECXNLIEN,ECXNLNM,ECXPRIME
+ S:'$D(ECXALL) ECXALL=1 S:ECXALL="" ECXALL=1
+ S (ECXERR,OUT)=0,ECXSC=""
+ ;get ien in file #40.8 of primary division
+ S ECXPRIME=$$PRIM^VASITE(DT)
+ ;associate nursing locations with medical center divisions
+ F  S ECXSC=$O(^NURSF(211.4,"B",ECXSC)) Q:ECXSC=""  S ECXNLIEN="" F  S ECXNLIEN=$O(^NURSF(211.4,"B",ECXSC,ECXNLIEN)) Q:ECXNLIEN=""  D
+ .K ECX
+ .S ECXDIEN=0,ECXNLNM="",DIC="^SC(",DIQ(0)="I",DIQ="ECX",DA=ECXSC,DR=".01;3.5" D EN^DIQ1
+ .;if the 15th piece is null or y=-1 then ecxdien=primary division as default
+ .I $D(ECX) S ECXDIEN=+ECX(44,ECXSC,3.5,"I"),ECXNLNM=ECX(44,ECXSC,.01,"I")
+ .S:ECXDIEN=0 ECXDIEN=ECXPRIME
+ .S ECXLOC(ECXDIEN)="",ECXLOC(ECXDIEN,ECXNLIEN)=ECXSC_U_ECXNLNM
+ ;
+ ;if ecxall=1 don't prompt; setup all nursing locations and divisions incl. those w/o division
+ I ECXALL=1 S ECXDIEN="" D
+ .F  S ECXDIEN=$O(ECXLOC(ECXDIEN)) Q:ECXDIEN=""  D
+ ..S DIC="^DG(40.8,",DIC(0)="NXZ",X=ECXDIEN D ^DIC I +Y>0 D
+ ...S ECXDIV("D",ECXDIEN)=$P(Y(0),U,7)_U_$P(Y(0),U,1)_U_$P(Y(0),U,2),ECXNLIEN=""
+ ...F  S ECXNLIEN=$O(ECXLOC(ECXDIEN,ECXNLIEN)) Q:ECXNLIEN=""  S ECXDIV(ECXNLIEN,ECXDIEN)=ECXLOC(ECXDIEN,ECXNLIEN)
+ ;
+ ;if ecxall=0 let user select division(s)
+ I ECXALL=0 F  Q:OUT!ECXERR  D
+ .S DIC="^DG(40.8,",DIC(0)="AEMQZ",DIC("S")="I $P(^(0),U,3)'=1"
+ .D ^DIC I $G(DUOUT)!($G(DTOUT)) S OUT=1,ECXERR=1 Q
+ .I Y=-1,X="" S OUT=1 Q
+ .S ECXDIEN=+Y,NM=$P(Y,U,2)
+ .I '$D(ECXLOC(ECXDIEN)) D  Q
+ ..W !!,?5,"Division "_NM_" not associated with Nursing Locations.",!,?5,"Try again...",!
+ .S ECXDIV("D",ECXDIEN)=$P(Y(0),U,7)_U_$P(Y(0),U,1)_U_$P(Y(0),U,2),ECXNLIEN=""
+ .F  S ECXNLIEN=$O(ECXLOC(ECXDIEN,ECXNLIEN)) Q:ECXNLIEN=""  S ECXDIV(ECXNLIEN,ECXDIEN)=ECXLOC(ECXDIEN,ECXNLIEN)
+ ;in case of user up-arrow out or timeout, make sure nothing returned in ecxdiv
+ I ECXERR=1 K ECXDIV
+ I '$D(ECXDIV) S ECXERR=1
+ Q
+ ;
+PRE(ECXDIV,ECXALL,ECXERR) ;setup site information for PRE extract audit report
+ ;   input
+ ;   ECXDIV = passed by reference array variable (required)
+ ;   ECXALL = 0/1 (optional)
+ ;            '0' indicates user to select Pharmacy site(s);
+ ;            '1' indicates 'all' sites are selected
+ ;            default is '1'
+ ;   output
+ ;   ECXDIV = data for Pharmacy site(s);
+ ;            ECXDIV(ien in file #59)=IEN in file #59^name^site number^IEN in file #4
+ ;   ECXERR = 0/1
+ ;            if input problem, then '1' returned
+ ;
+ N X,Y,DIC,DIQ,DA,OUT,ECXARR,ECXP,ECXIEN
+ S:'$D(ECXALL) ECXALL=1 S:ECXALL="" ECXALL=1
+ S ECXERR=0,ECXP=""
+ ;if ecxall=1, then all pharmacy sites are selected or there's only one
+ I ECXALL=1 S ECXP="" D
+ .F  S ECXP=$O(^PS(59,"B",ECXP)) Q:ECXP=""  S ECXIEN=$O(^(ECXP,"")) D
+ ..K ECXARR S DIC="^PS(59,",DR=".01;.06;100",DIQ="ECXARR",DA=ECXIEN D EN^DIQ1
+ ..Q:'$D(ECXARR)
+ ..S ECXDIV(ECXIEN)=ECXIEN_U_ECXARR(59,ECXIEN,.01)_U_ECXARR(59,ECXIEN,.06)_U_ECXARR(59,ECXIEN,100)
+ ;if ecxall=0, then user selects pharmacy site(s)
+ I ECXALL=0 S OUT=0 D
+ .F  Q:OUT!ECXERR  D
+ ..S DIC="^PS(59,",DIC(0)="AEMQZ" K X,Y D ^DIC
+ ..I $G(DUOUT)!($G(DTOUT)) S OUT=1,ECXERR=1 Q
+ ..I Y=-1,X="" S OUT=1 Q
+ ..K ECXARR S (ECXIEN,DA)=+Y,DIC="^PS(59,",DR=".01;.06;100",DIQ="ECXARR" D EN^DIQ1
+ ..Q:'$D(ECXARR)
+ ..S ECXDIV(ECXIEN)=ECXIEN_U_ECXARR(59,ECXIEN,.01)_U_ECXARR(59,ECXIEN,.06)_U_ECXARR(59,ECXIEN,100)
+ ;
+ I ECXERR=1 K ECXDIV
+ I '$D(ECXDIV) S ECXERR=1
+ Q

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXEC.m

@@ -1 @@
-ECXEC   ;ALB/JAP,BIR/JLP,PTD-DSS Event Capture Extract  ; 10/2/07 2:33pm
-        ;;3.0;DSS EXTRACTS;**11,8,13,24,27,33,39,46,49,71,89,92,105**;Dec 22, 1997;Build 70
-BEG     ;entry point from option
-        I '$D(^ECH) W !,"Event Capture is not initialized",!! Q
-        D SETUP I ECFILE="" Q
-        D ^ECXTRAC,^ECXKILL
-        Q
-START   ;begin EC extract
-        N X,Y,ECDCM,ECXNPRFI
-        S ECED=ECED+.3,ECLL=0
-        K ^TMP("EC",$J)
-        F  S ECLL=$O(^ECH("AC1",ECLL)),ECD=ECSD-.1 Q:'ECLL  D
-        .F  S ECD=$O(^ECH("AC1",ECLL,ECD)),ECDA=0 Q:(ECD>ECED)!('ECD)  D
-        ..F  S ECDA=$O(^ECH("AC1",ECLL,ECD,ECDA)) Q:'ECDA  D UPDATE
-        Q
-        ;
-UPDATE  ;sets record and updates counters
-        S ECCH=^ECH(ECDA,0),ECL=$P(ECCH,U,4),ECXDFN=$P(ECCH,U,2)
-        S ECXPDIV=$$RADDIV^ECXDEPT(ECL)  ;Get production division from file 4
-        S ECDT=$P(ECCH,U,3),ECM=$P(ECCH,U,6),ECC=$P(ECCH,U,8)
-        Q:'$$PATDEM^ECXUTL2(ECXDFN,ECDT,"1;3;5;")
-        S ECTM=$$ECXTIME^ECXUTL(ECDT),ECP=$P(ECCH,U,9)
-        Q:ECP']""
-        S ECO=$P(ECCH,U,12),ECV=$P(ECCH,U,10),ECDU=$P(ECCH,U,7)
-        S ECXUNIT=$G(^ECD(ECDU,0)),ECCS=+$P(ECXUNIT,U,4),ECDCM=$P(ECXUNIT,U,5)
-        S ECXDSSP="",ECXDSSD=$E(ECDCM,1,10),ECUSTOP=$P(ECXUNIT,U,10),ECUPCE=$P(ECXUNIT,U,14)
-        S ICD9=$P($G(^ECH(ECDA,"P")),U,2) S:ICD9="" ICD9=" "
-        S ECXICD9=$P($G(^ICD9(ICD9,0)),U)
-        F I=1:1:4 S @("ECXICD9"_I)=""
-        S (CNT,I)=0
-        F  S CNT=$O(^ECH(ECDA,"DX",CNT)) Q:'CNT  D  Q:I>3
-        .S ICD9=$P($G(^ECH(ECDA,"DX",CNT,0)),U) D:ICD9'=""
-        ..S I=I+1,@("ECXICD9"_I)=$P($G(^ICD9(ICD9,0)),U)
-        ;derivation of dss identifier depends on whether dss unit is 
-        ;set to send data to pce
-        S ECAC=$P($G(ECCH),U,19)
-        ;if this is a record that 'goes to pce', then get the dss identifier
-        ;from the clinic stop codes
-        S (ECAC1S,ECAC2S)="000"
-        I ECUPCE="A"!(ECUPCE="O"&(ECXA="O")) D
-        .D:+ECAC
-        ..S ECAC1=$P($G(^SC(+ECAC,0)),U,7),ECAC2=$P($G(^(0)),U,18)
-        ..I 'ECAC2 S ECAC2S="000"
-        ..I 'ECAC1 S (ECAC1S,ECAC2S)="000" Q
-        ..S ECAC1S=$P($G(^DIC(40.7,+ECAC1,0)),U,2)
-        ..S ECAC2S=$P($G(^DIC(40.7,+ECAC2,0)),U,2)
-        ..S ECAC1S=$$RJ^XLFSTR(ECAC1S,3,0),ECAC2S=$$RJ^XLFSTR(ECAC2S,3,0)
-        .S:'ECAC (ECAC1S,ECAC2S)="000"
-        ;if this record doesn't go to pce, then get the dss identifier
-        ;from the dss unit
-        I ECUPCE=""!(ECUPCE="N")!(ECUPCE="O"&(ECXA="I")) D
-        .I +ECUSTOP D
-        ..S ECAC1S=$P($G(^DIC(40.7,+ECUSTOP,0)),U,2)
-        ..S ECAC1S=$$RJ^XLFSTR(ECAC1S,3,0),ECAC2S="000"
-        .I 'ECUSTOP D
-        ..S (ECAC1S,ECAC2S)="000"
-        S ECDSS=ECAC1S_ECAC2S
-        I ECXLOGIC>2003 I "^18^23^24^36^41^65^94^"[("^"_ECXTS_"^") S ECDSS=$$TSMAP^ECXUTL4(ECXTS)
-        S ECXDIV=""
-        ;
-        ;- Ord Div, Contrct St/End Dates, Contrct Type placeholders for FY2002
-        S (ECXODIV,ECXCSDT,ECXCEDT,ECXCTYP)=""
-        ;setup provider(s) as'2'_ien
-        S (ECU1A,ECU2A,ECU3A,ECU1NPI,ECU2NPI,ECU3NPI,ECXPPC1,ECXPPC2,ECXPPC3)=""
-        S (ECU1,ECU2,ECU3)=""
-        K ECXPRV S ECXPROV=$$GETPRV^ECPRVMUT(ECDA,.ECXPRV) I ECXPROV Q
-        F I=1:1:3 S Y=$O(ECXPRV("")) I Y'="" S @("ECU"_I)=+ECXPRV(Y) K ECXPRV(Y)
-        S:$L(ECU1) ECXPPC1=$$PRVCLASS^ECXUTL(ECU1,ECDT),ECU1A="2"_$P(ECU1,";")
-        S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",ECU1,ECDT)
-        S:+ECXUSRTN'>0 ECXUSRTN="" S ECU1NPI=$P(ECXUSRTN,U)
-        S:$L(ECU2) ECXPPC2=$$PRVCLASS^ECXUTL(ECU2,ECDT),ECU2A="2"_$P(ECU2,";")
-        S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",ECU2,ECDT)
-        S:+ECXUSRTN'>0 ECXUSRTN="" S ECU2NPI=$P(ECXUSRTN,U)
-        S:$L(ECU3) ECXPPC3=$$PRVCLASS^ECXUTL(ECU3,ECDT),ECU3A="2"_$P(ECU3,";")
-        S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",ECU3,ECDT)
-        S:+ECXUSRTN'>0 ECXUSRTN="" S ECU3NPI=$P(ECXUSRTN,U)
-        ;change for version 2 where ECP is a variable pointer and we want to
-        ;expand it category = category or null if stored as 0
-        D:ECP[";"
-        .S ECP=$S(ECP["ICPT":$P(^ICPT(+ECP,0),U)_"01",ECP<90000:$P(^EC(725,+ECP,0),U,2)_"N",1:$P(^EC(725,+ECP,0),U,2)_"L"),ECC=$S(ECC:ECC,1:"")
-        ;pick up EC to PCE data from "P" in File 721
-        S ECPCE=$G(^ECH(ECDA,"P")),ECPCE1=$P(ECPCE,U),ECPCE2=$P(ECPCE,U,2)
-        S ECPCE7=$S($P(ECPCE,U,7)=1:"Y",1:"N")
-        S ECXCMOD=""
-        I $D(^ECH(ECDA,"MOD")) D
-        .S MOD=0,M=""
-        .F  S MOD=$O(^ECH(ECDA,"MOD",MOD)) Q:'MOD  S M=$P(^(MOD,0),U) D
-        ..I M S ECXCMOD=ECXCMOD_M_";"
-        .K MOD,M
-        S:ECP?1.N ECP=$$CPT^ECXUTL3($E(ECP,1,5),"",ECV)
-        S ECXCPT=$$CPT^ECXUTL3(ECPCE1,ECXCMOD,ECV)
-        ;
-        ;- Observation Patient Indicator (YES/NO)
-        S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECDSS)
-        ;
-        ;- CNH status (YES/NO)
-        S ECXCNH=$$CNHSTAT^ECXUTL4(ECXDFN)
-        ;
-        ;- encounter classification
-        S (ECXAO,ECXECE,ECXHNC,ECXMIL,ECXIR)="",ECXVISIT=$P(ECCH,U,21)
-        I ECXVISIT'="" D
-        .D VISIT^ECXSCX1(ECXDFN,ECXVISIT,.ECXVIST,.ECXERR) I ECXERR K ECXERR Q
-        .S ECXAO=$G(ECXVIST("AO")),ECXECE=$G(ECXVIST("PGE"))
-        .S ECXHNC=$G(ECXVIST("HNC")),ECXMIL=$G(ECXVIST("MST")),ECXIR=$G(ECXVIST("IR"))
-        ; - Head and Neck Cancer Indicator
-        S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN)
-        ;
-        ; - Get national patient record flag Indicator if exist
-        D NPRF^ECXUTL5
-        ;
-        ; - If no encounter number don't file record
-        S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECDT,ECXTS,ECXOBS,ECHEAD,ECDSS,ECCS)
-        D:ECXENC'="" FILE
-        Q
-        ;
-FILE    ;file record in #727.815
-        ;node0
-        ;ecode=inst ECL^dfn ECXDFN^ssn ECXSSN^name ECXPNM^i/o status ECXA^day^
-        ;DSS unit ECDU^category ECC^procedure ECP^volume ECV^
-        ;cost center ECCS^ordering sec ECO^section ECM^
-        ;provider ECU1A^prov per cls ECXPPC1^prov 2 ECU2A^prov#2 per cls ECXPPC2
-        ;^prov 3 ECU3A^prov#3 per cls ECXPPC3^^mov # ECXMN^treat spec ECXTS
-        ;^time ECTM^primary care team ECPTTM^primary care provider ECPTPR
-        ;^pce cpt code (ECXCPT)^primary icd-9 code ECXICD9^secondary icd-9
-        ;ECXICD91^secondary icd-9 ECXICD92^secondary icd-9 ECXICD93^secondary 
-        ;icd-9 ECXICD94^agent orange ECXAST^radiation exposure ECXRST^
-        ;environmental contaminants ECXEST^service connected ECPTPR^sent to pce
-        ;ECPCE7^^dss identifier ECDSS^dss dept
-        ;node1
-        ;mpi ECXMPI^dss dept ECXDSSD^PLACEHOLDER
-        ;placeholder^placeholder^placeholder^
-        ;placeholder^pc prov person class ECCLAS^
-        ;assoc pc prov ECASPR^assoc pc prov person class ECCLAS2^
-        ;placeholder^
-        ;divison ECXDIV^mst status ECXMST^dom ECXDOM^date of birth ECXDOB^
-        ;enrollment category ECXCAT^ enrollment status ECXSTAT^enrollment
-        ;priority ECXPRIOR^period of service ECXPOS^purple heart indicator
-        ;ECXPHI^observ pat ind ECXOBS^encounter num ECXENC^
-        ;ao loc ECXAOL^ord div ECXODIV^contr st dt ECXCSDT^
-        ;contr end dt ECXCEDT^contr typ ECXCTYP^CNH stat ECXCNH^
-        ;production division ECXPDIV^eligibility ECXELIG^
-        ;head & neck cancer ind. ECXHNCI^ethnicity ECXETH^race1 ECXRAC1
-        ;enrollment location ECXENRL^^enrollment priority
-        ;ECXPRIOR_enrollment subgroup ECXSBGRP^user enrollee ECXUESTA^patient
-        ;type ECXPTYPE^combat vet elig ECXCVE^combat vet elig end date
-        ;ECXCVEDT^enc cv eligible ECXCVENC^national patient record flag
-        ;ECXNPRFI^emerg response indic(FEMA) ECXERI^agent orange indic ECXAO^
-        ;environ contam ECXECE^head/neck cancer ECXHNC^encntr mst ECXMIL
-        ;^radiation ECXIR^OEF/OIF ECXOEF^OEF/OIF return date ECXOEFDT
-        ;^associate pc provider npi ECASNPI^primary care provider npi ECPTNPI^
-        ;provider npi ECU1NPI^provider #2 ECU2NPI^provider #3 ECU3NPI
-        N DA,DIK
-        S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1
-        S ECODE=EC7_U_EC23_U_ECL_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U
-        S ECODE=ECODE_$$ECXDATE^ECXUTL(ECDT,ECXYM)_U_ECDU_U_ECC_U
-        S ECODE=ECODE_ECP_U_ECV_U_ECCS_U_ECO_U_ECM_U_ECU1A_U_ECXPPC1_U
-        S ECODE=ECODE_ECU2A_U_ECXPPC2_U_ECU3A_U_ECXPPC3_U_U_ECXMN_U
-        S ECODE=ECODE_ECXTS_U_ECTM_U
-        S ECODE=ECODE_ECPTTM_U_ECPTPR_U_ECXCPT_U_ECXICD9_U
-        S ECODE=ECODE_ECXICD91_U_ECXICD92_U_ECXICD93_U
-        S ECODE=ECODE_ECXICD94_U_ECXAST_U_ECXRST_U_ECXEST_U
-        S ECODE=ECODE_ECSC_U_ECPCE7_U_U_ECDSS_U_U
-        S ECODE1=ECXMPI_U_ECXDSSD_U_U_U_U_ECCLAS_U
-        S ECODE1=ECODE1_U_ECASPR_U_ECCLAS2_U_U_ECXDIV_U
-        S ECODE1=ECODE1_ECXMST_U_ECXDOM_U_ECXDOB_U_ECXCAT_U_ECXSTAT_U
-        S ECODE1=ECODE1_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXPOS_U_ECXPHI_U_ECXOBS_U_ECXENC_U_ECXAOL_U
-        S ECODE1=ECODE1_ECXODIV_U_ECXCSDT_U_ECXCEDT_U_ECXCTYP_U_ECXCNH_U_ECXPDIV_U
-        S ECODE1=ECODE1_ECXELIG_U_ECXHNCI_U_ECXETH_U_ECXRC1
-        I ECXLOGIC>2003 S ECODE1=ECODE1_U_ECXENRL_U
-        I ECXLOGIC>2004 S ECODE1=ECODE1_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U
-        I ECXLOGIC>2004 S ECODE2=ECXCVEDT_U_ECXCVENC_U_ECXNPRFI
-        I ECXLOGIC>2006 S ECODE2=ECODE2_U_ECXERI_U_ECXAO_U_ECXECE_U_ECXHNC_U_ECXMIL_U_ECXIR_U
-        I ECXLOGIC>2007 S ECODE2=ECODE2_U_ECXOEF_U_ECXOEFDT_U_ECASNPI_U_ECPTNPI_U_ECU1NPI_U_ECU2NPI_U_ECU3NPI
-        S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,^ECX(ECFILE,EC7,2)=$G(ECODE2),ECRN=ECRN+1
-        S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA
-        I $D(ZTQUEUED),$$S^%ZTLOAD
-        Q
-        ;
-SETUP   ;Set required input for ECXTRAC
-        S ECHEAD="ECS"
-        D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
-        Q
-        ;
-QUE     ; entry point for the background requeuing handled by ECXTAUTO
-        D SETUP,QUE^ECXTAUTO,^ECXKILL Q
+ECXEC ;ALB/JAP,BIR/JLP,PTD-DSS Event Capture Extract  [ 02/14/97   2:26 PM ] ; 12/2/04 12:35pm
+ ;;3.0;DSS EXTRACTS;**11,8,13,24,27,33,39,46,49,71,89,92**;Dec 22, 1997;Build 30
+BEG ;entry point from option
+ I '$D(^ECH) W !,"Event Capture is not initialized",!! Q
+ D SETUP I ECFILE="" Q
+ D ^ECXTRAC,^ECXKILL
+ Q
+START ;begin EC extract
+ N X,Y,ECDCM,ECXNPRFI
+ S ECED=ECED+.3,ECLL=0
+ K ^TMP("EC",$J)
+ F  S ECLL=$O(^ECH("AC1",ECLL)),ECD=ECSD-.1 Q:'ECLL  D
+ .F  S ECD=$O(^ECH("AC1",ECLL,ECD)),ECDA=0 Q:(ECD>ECED)!('ECD)  D
+ ..F  S ECDA=$O(^ECH("AC1",ECLL,ECD,ECDA)) Q:'ECDA  D UPDATE
+ Q
+ ;
+UPDATE ;sets record and updates counters
+ S ECCH=^ECH(ECDA,0),ECL=$P(ECCH,U,4),ECXDFN=$P(ECCH,U,2)
+ S ECXPDIV=$$RADDIV^ECXDEPT(ECL)  ;Get production division from file 4
+ S ECDT=$P(ECCH,U,3),ECM=$P(ECCH,U,6),ECC=$P(ECCH,U,8)
+ Q:'$$PATDEM^ECXUTL2(ECXDFN,ECDT,"1;3;5;")
+ S ECTM=$$ECXTIME^ECXUTL(ECDT),ECP=$P(ECCH,U,9)
+ Q:ECP']""
+ S ECO=$P(ECCH,U,12),ECV=$P(ECCH,U,10),ECDU=$P(ECCH,U,7)
+ S ECXUNIT=$G(^ECD(ECDU,0)),ECCS=+$P(ECXUNIT,U,4),ECDCM=$P(ECXUNIT,U,5)
+ S ECXDSSP="",ECXDSSD=$E(ECDCM,1,10),ECUSTOP=$P(ECXUNIT,U,10),ECUPCE=$P(ECXUNIT,U,14)
+ S ICD9=$P($G(^ECH(ECDA,"P")),U,2) S:ICD9="" ICD9=" "
+ S ECXICD9=$P($G(^ICD9(ICD9,0)),U)
+ F I=1:1:4 S @("ECXICD9"_I)=""
+ S (CNT,I)=0
+ F  S CNT=$O(^ECH(ECDA,"DX",CNT)) Q:'CNT  D  Q:I>3
+ .S ICD9=$P($G(^ECH(ECDA,"DX",CNT,0)),U) D:ICD9'=""
+ ..S I=I+1,@("ECXICD9"_I)=$P($G(^ICD9(ICD9,0)),U)
+ ;derivation of dss identifier depends on whether dss unit is 
+ ;set to send data to pce
+ S ECAC=$P($G(ECCH),U,19)
+ ;if this is a record that 'goes to pce', then get the dss identifier
+ ;from the clinic stop codes
+ S (ECAC1S,ECAC2S)="000"
+ I ECUPCE="A"!(ECUPCE="O"&(ECXA="O")) D
+ .D:+ECAC
+ ..S ECAC1=$P($G(^SC(+ECAC,0)),U,7),ECAC2=$P($G(^(0)),U,18)
+ ..I 'ECAC2 S ECAC2S="000"
+ ..I 'ECAC1 S (ECAC1S,ECAC2S)="000" Q
+ ..S ECAC1S=$P($G(^DIC(40.7,+ECAC1,0)),U,2)
+ ..S ECAC2S=$P($G(^DIC(40.7,+ECAC2,0)),U,2)
+ ..S ECAC1S=$$RJ^XLFSTR(ECAC1S,3,0),ECAC2S=$$RJ^XLFSTR(ECAC2S,3,0)
+ .S:'ECAC (ECAC1S,ECAC2S)="000"
+ ;if this record doesn't go to pce, then get the dss identifier
+ ;from the dss unit
+ I ECUPCE=""!(ECUPCE="N")!(ECUPCE="O"&(ECXA="I")) D
+ .I +ECUSTOP D
+ ..S ECAC1S=$P($G(^DIC(40.7,+ECUSTOP,0)),U,2)
+ ..S ECAC1S=$$RJ^XLFSTR(ECAC1S,3,0),ECAC2S="000"
+ .I 'ECUSTOP D
+ ..S (ECAC1S,ECAC2S)="000"
+ S ECDSS=ECAC1S_ECAC2S
+ I ECXLOGIC>2003 I "^18^23^24^36^41^65^94^"[("^"_ECXTS_"^") S ECDSS=$$TSMAP^ECXUTL4(ECXTS)
+ S ECXDIV=""
+ ;
+ ;- Ord Div, Contrct St/End Dates, Contrct Type placeholders for FY2002
+ S (ECXODIV,ECXCSDT,ECXCEDT,ECXCTYP)=""
+ ;setup provider(s) as'2'_ien
+ S (ECU1A,ECU2A,ECU3A,ECU1NPI,ECU2NPI,ECU3NPI,ECXPPC1,ECXPPC2,ECXPPC3)=""
+ S (ECU1,ECU2,ECU3)=""
+ K ECXPRV S ECXPROV=$$GETPRV^ECPRVMUT(ECDA,.ECXPRV) I ECXPROV Q
+ F I=1:1:3 S Y=$O(ECXPRV("")) I Y'="" S @("ECU"_I)=+ECXPRV(Y) K ECXPRV(Y)
+ S:$L(ECU1) ECXPPC1=$$PRVCLASS^ECXUTL(ECU1,ECDT),ECU1A="2"_$P(ECU1,";")
+ S:$L(ECU2) ECXPPC2=$$PRVCLASS^ECXUTL(ECU2,ECDT),ECU2A="2"_$P(ECU2,";")
+ S:$L(ECU3) ECXPPC3=$$PRVCLASS^ECXUTL(ECU3,ECDT),ECU3A="2"_$P(ECU3,";")
+ ;change for version 2 where ECP is a variable pointer and we want to
+ ;expand it category = category or null if stored as 0
+ D:ECP[";"
+ .S ECP=$S(ECP["ICPT":$P(^ICPT(+ECP,0),U)_"01",ECP<90000:$P(^EC(725,+ECP,0),U,2)_"N",1:$P(^EC(725,+ECP,0),U,2)_"L"),ECC=$S(ECC:ECC,1:"")
+ ;pick up EC to PCE data from "P" in File 721
+ S ECPCE=$G(^ECH(ECDA,"P")),ECPCE1=$P(ECPCE,U),ECPCE2=$P(ECPCE,U,2)
+ S ECPCE7=$S($P(ECPCE,U,7)=1:"Y",1:"N")
+ S ECXCMOD=""
+ I $D(^ECH(ECDA,"MOD")) D
+ .S MOD=0,M=""
+ .F  S MOD=$O(^ECH(ECDA,"MOD",MOD)) Q:'MOD  S M=$P(^(MOD,0),U) D
+ ..I M S ECXCMOD=ECXCMOD_M_";"
+ .K MOD,M
+ S:ECP?1.N ECP=$$CPT^ECXUTL3($E(ECP,1,5),"",ECV)
+ S ECXCPT=$$CPT^ECXUTL3(ECPCE1,ECXCMOD,ECV)
+ ;
+ ;- Observation Patient Indicator (YES/NO)
+ S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECDSS)
+ ;
+ ;- CNH status (YES/NO)
+ S ECXCNH=$$CNHSTAT^ECXUTL4(ECXDFN)
+ ;
+ ;- encounter classification
+ S (ECXAO,ECXECE,ECXHNC,ECXMIL,ECXIR)="",ECXVISIT=$P(ECCH,U,21)
+ I ECXVISIT'="" D
+ .D VISIT^ECXSCX1(ECXDFN,ECXVISIT,.ECXVIST,.ECXERR) I ECXERR K ECXERR Q
+ .S ECXAO=$G(ECXVIST("AO")),ECXECE=$G(ECXVIST("PGE"))
+ .S ECXHNC=$G(ECXVIST("HNC")),ECXMIL=$G(ECXVIST("MST")),ECXIR=$G(ECXVIST("IR"))
+ ; - Head and Neck Cancer Indicator
+ S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN)
+ ;
+ ; - Get national patient record flag Indicator if exist
+ D NPRF^ECXUTL5
+ ;
+ ; - If no encounter number don't file record
+ S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECDT,ECXTS,ECXOBS,ECHEAD,ECDSS,ECCS)
+ D:ECXENC'="" FILE
+ Q
+ ;
+FILE ;file record in #727.815
+ ;node0
+ ;ecode=inst ECL^dfn ECXDFN^ssn ECXSSN^name ECXPNM^i/o status ECXA^day^
+ ;DSS unit ECDU^category ECC^procedure ECP^volume ECV^
+ ;cost center ECCS^ordering sec ECO^section ECM^
+ ;provider ECU1A^prov per cls ECXPPC1^prov 2 ECU2A^prov#2 per cls ECXPPC2
+ ;^prov 3 ECU3A^prov#3 per cls ECXPPC3^^mov # ECXMN^treat spec ECXTS
+ ;^time ECTM^primary care team ECPTTM^primary care provider ECPTPR
+ ;^pce cpt code (ECXCPT)^primary icd-9 code ECXICD9^secondary icd-9
+ ;ECXICD91^secondary icd-9 ECXICD92^secondary icd-9 ECXICD93^secondary 
+ ;icd-9 ECXICD94^agent orange ECXAST^radiation exposure ECXRST^
+ ;environmental contaminants ECXEST^service connected ECPTPR^sent to pce
+ ;ECPCE7^^dss identifier ECDSS^dss dept
+ ;node1
+ ;mpi ECXMPI^dss dept ECXDSSD^provider npi ECXPRV2^
+ ;provider #2 npi ECU2NPI^provider #3 npi ECU3NPI^^
+ ;pc provider npi ECPTNPI^pc prov person class ECCLAS^
+ ;assoc pc prov ECASPR^assoc pc prov person class ECCLAS2^
+ ;assoc pc prov npi ECASNPI^
+ ;divison ECXDIV^mst status ECXMST^dom ECXDOM^date of birth ECXDOB^
+ ;enrollment category ECXCAT^ enrollment status ECXSTAT^enrollment
+ ;priority ECXPRIOR^period of service ECXPOS^purple heart indicator
+ ;ECXPHI^observ pat ind ECXOBS^encounter num ECXENC^
+ ;ao loc ECXAOL^ord div ECXODIV^contr st dt ECXCSDT^
+ ;contr end dt ECXCEDT^contr typ ECXCTYP^CNH stat ECXCNH^
+ ;production division ECXPDIV^eligibility ECXELIG^
+ ;head & neck cancer ind. ECXHNCI^ethnicity ECXETH^race1 ECXRAC1
+ ;enrollment location ECXENRL^^enrollment priority
+ ;ECXPRIOR_enrollment subgroup ECXSBGRP^user enrollee ECXUESTA^patient
+ ;type ECXPTYPE^combat vet elig ECXCVE^combat vet elig end date
+ ;ECXCVEDT^enc cv eligible ECXCVENC^national patient record flag
+ ;ECXNPRFI^emerg response indic(FEMA) ECXERI^agent orange indic ECXAO^
+ ;environ contam ECXECE^head/neck cancer ECXHNC^encntr mst ECXMIL
+ ;^radiation ECXIR
+ N DA,DIK
+ S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1
+ S ECODE=EC7_U_EC23_U_ECL_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U
+ S ECODE=ECODE_$$ECXDATE^ECXUTL(ECDT,ECXYM)_U_ECDU_U_ECC_U
+ S ECODE=ECODE_ECP_U_ECV_U_ECCS_U_ECO_U_ECM_U_ECU1A_U_ECXPPC1_U
+ S ECODE=ECODE_ECU2A_U_ECXPPC2_U_ECU3A_U_ECXPPC3_U_U_ECXMN_U
+ S ECODE=ECODE_ECXTS_U_ECTM_U
+ S ECODE=ECODE_ECPTTM_U_ECPTPR_U_ECXCPT_U_ECXICD9_U
+ S ECODE=ECODE_ECXICD91_U_ECXICD92_U_ECXICD93_U
+ S ECODE=ECODE_ECXICD94_U_ECXAST_U_ECXRST_U_ECXEST_U
+ S ECODE=ECODE_ECSC_U_ECPCE7_U_U_ECDSS_U_U
+ S ECODE1=ECXMPI_U_ECXDSSD_U_ECU1NPI_U_ECU2NPI_U_ECU3NPI_U_ECCLAS_U
+ S ECODE1=ECODE1_ECPTNPI_U_ECASPR_U_ECCLAS2_U_ECASNPI_U_ECXDIV_U
+ S ECODE1=ECODE1_ECXMST_U_ECXDOM_U_ECXDOB_U_ECXCAT_U_ECXSTAT_U
+ S ECODE1=ECODE1_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXPOS_U_ECXPHI_U_ECXOBS_U_ECXENC_U_ECXAOL_U
+ S ECODE1=ECODE1_ECXODIV_U_ECXCSDT_U_ECXCEDT_U_ECXCTYP_U_ECXCNH_U_ECXPDIV_U
+ S ECODE1=ECODE1_ECXELIG_U_ECXHNCI_U_ECXETH_U_ECXRC1
+ I ECXLOGIC>2003 S ECODE1=ECODE1_U_ECXENRL_U
+ I ECXLOGIC>2004 S ECODE1=ECODE1_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U
+ I ECXLOGIC>2004 S ECODE2=ECXCVEDT_U_ECXCVENC_U_ECXNPRFI
+ I ECXLOGIC>2006 S ECODE2=ECODE2_U_ECXERI_U_ECXAO_U_ECXECE_U_ECXHNC_U_ECXMIL_U_ECXIR_U
+ S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,^ECX(ECFILE,EC7,2)=$G(ECODE2),ECRN=ECRN+1
+ S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA
+ I $D(ZTQUEUED),$$S^%ZTLOAD
+ Q
+ ;
+SETUP ;Set required input for ECXTRAC
+ S ECHEAD="ECS"
+ D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
+ Q
+ ;
+QUE ; entry point for the background requeuing handled by ECXTAUTO
+ D SETUP,QUE^ECXTAUTO,^ECXKILL Q

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXFELOC.m

@@ -1 @@
-ECXFELOC        ;BIR/DMA,CML-Print Feeder Locations; [ 05/07/96  8:41 AM ] ; 6/12/07 6:29am
-        ;;3.0;DSS EXTRACTS;**1,8,105**;Dec 22, 1997;Build 70
-EN      ;entry point from option
-        W !!,"Print list of feeder locations.",! S QFLG=1
-        K %ZIS S %ZIS="Q" D ^%ZIS Q:POP 
-        I $D(IO("Q")) S ZTDESC="Feeder Location List (DSS)",ZTRTN="START^ECXFELOC" D ^%ZTLOAD D ^%ZISC G OUT
-        U IO
-START   ;queued entry point
-        I '$D(DT) S DT=$$HTFM^XLFDT(+$H)
-        K ^TMP($J) S (QFLG,PG)=0,$P(LN,"-",81)=""
-LAB     S EC=0 F  S EC=$O(^LRO(68,EC)) Q:'EC  I $D(^(EC,0)) S EC1=^(0),^TMP($J,"LAB",$P(EC1,U,11),EC)=$P(EC1,U)
-ECS     S EC=0 I $P($G(^EC(720.1,1,0)),U,2) D  G IV
-        .F  S EC=$O(^ECJ(EC)) Q:'EC  I $D(^(EC,0)) S EC1=$P(^(0),"-",1,2),EC2=$P($G(^ECD(+$P(EC1,"-",2),0)),U),^TMP($J,"ECS",EC1,EC1)=EC2
-        F  S EC=$O(^ECK(EC)) Q:'EC  I $D(^(EC,0)) S EC1=$P(^(0),"-",1,2),EC2=$P($G(^ECD(+$P(EC1,"-",2),0)),U),^TMP($J,"ECS",EC1,EC1)=EC2
-IV      S EC=0 F  S EC=$O(^DG(40.8,EC)) Q:'EC  I $D(^DG(40.8,EC,0)) S EC1=$E($P(^(0),U),1,30),^TMP($J,"IVP","IVP"_EC,EC)="IV Pharmacy-"_EC1
-CLI     S EC=0 F  S EC=$O(^SC(EC)) Q:'EC  I $D(^(EC,0)) S EC1=^(0),ECS=$P(EC1,U,15),ECSC=$P($G(^DIC(40.7,+$P(EC1,U,7),0)),U,2),ECD=$P(EC1,U) S:'ECS ECS=1 D
-        .I $P(EC1,U,17)'="Y",$P(EC1,U,3)="C" S DAT=$G(^SC(EC,"I")),ID=+DAT,RD=$P(DAT,U,2) I 'ID!(ID>DT)!(RD&(RD<DT)) S ^TMP($J,"CLI",ECS_ECSC,EC)=ECD
-PRE     N ARRAY S ARRAY="^TMP($J,""ECXDSS"")" K @ARRAY D PSS^PSO59(,"??","ECXDSS") I @ARRAY@(0)>0 G V6
-        ;dbia (#4689)
-        S EC=0 F  S EC=$O(^DIC(59,EC)) Q:'EC  I $D(^(EC,0)) S EC1=$E($P(^(0),U),1,30),^TMP($J,"PRE","PRE"_EC,EC)="Prescriptions-"_EC1
-        G RAD
-V6      S EC=0 F  S EC=$O(@ARRAY@(EC)) Q:'EC  I $D(^(EC)) S EC1=$E(@ARRAY@(EC,.01),1,30),^TMP($J,"PRE","PRE"_EC,EC)="Prescriptions-"_EC1
-        K @ARRAY
-RAD     S EC=0 F  S EC=$O(^RA(79,EC)),EC1=0 Q:'EC  I $D(^(EC,0)) S ECD=$P(^(0),U) F  S EC1=$O(^RA(79.2,EC1)) Q:'EC1  I $D(^(EC1,0)) S ECD1=$P(^(0),U),^TMP($J,"RAD",EC_"-"_EC1,EC_"-"_EC1)=ECD_"-"_ECD1
-NUR     S EC=0 F  S EC=$O(^NURSF(211.4,EC)) Q:'EC  I $D(^(EC,0)) S EC1=$P(^(0),U),EC1=$P($G(^SC(+EC1,0)),U),^TMP($J,"NUR",EC,EC)=EC1
-SUR     F EC=1:1:14 S EC2=$P($T(@EC),";",3) F EC1="I","A","D","M","P","C","S" S EC3=$P($T(@EC1),";",3),^TMP($J,"SUR",$P(EC2,U)_EC1,EC)=$P(EC2,U,2)_"-"_EC3
-1       ;;ORGE^GENERAL PURPOSE OPERATING ROOM
-2       ;;OROR^ORTHOPEDIC OPERATING ROOM
-3       ;;ORCA^CARDIAC OPERATING ROOM
-4       ;;ORNE^NEUROSURGERY OPERATING ROOM
-5       ;;ORCN^CARDIAC/NEURO OPERATING ROOM
-6       ;;ORAM^AMBULATORY OPERATING ROOM
-7       ;;ORIN^INTENSIVE CARE UNIT
-8       ;;OREN^ENDOSCOPY ROOM
-9       ;;ORCY^CYSTOSCOPY ROOM
-10      ;;ORWA^WARD
-11      ;;ORCL^CLINIC
-12      ;;ORDE^DEDICATED ROOM
-13      ;;OROT^OTHER LOCATION
-14      ;;ORNO^UNKNOWN
-I       ;;IMPLANTS
-A       ;;ANESTHESIA TIME
-D       ;;SURGERY TIME (DENTAL)
-M       ;;SURGERY TIME (MEDICINE)
-P       ;;SURGERY TIME (PSYCH)
-C       ;;SURGERY TIME (SPINAL CORD)
-S       ;;SURGERY TIME (SURGERY)
-UDP     S EC=0 F  S EC=$O(^DG(40.8,EC)) Q:'EC  I $D(^DG(40.8,EC,0)) S EC1=$E($P(^(0),U),1,30),^TMP($J,"UDP","UDP"_EC,EC)="Unit Dose Medications-"_EC1
-DEN     S EC=0 F  S EC=$O(^DENT(225,EC)) Q:'EC  I $D(^(EC,0)) S EC1=$P(^(0),U),^TMP($J,"DEN",EC1,EC)="Dental "_EC1
-        ;
-PRINT   ;
-        S EC="" F  S EC=$O(^TMP($J,EC)),EC1="" Q:EC=""  Q:QFLG  D HEAD Q:QFLG  F  S EC1=$O(^TMP($J,EC,EC1)),EC2=""  Q:EC1=""  Q:QFLG  F  S EC2=$O(^TMP($J,EC,EC1,EC2)) Q:EC2=""  Q:QFLG  D
-        .W !,?5,EC1,?23,^(EC2) I $Y+3>IOSL D HEAD Q:QFLG
-OUT     I $E(IOST)="C"&('QFLG) S DIR(0)="E" D  D ^DIR K DIR
-        .S SS=22-$Y F JJ=1:1:SS W !
-        K ^TMP($J),DAT,EC,EC1,EC2,EC3,ECD,ECD1,ECS,ECSC,ID,JJ,LN,PG,POP,QFLG,RD,SS,X,Y
-        W:$E(IOST)'="C" @IOF D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" Q
-HEAD    ;
-        I $E(IOST)="C" S SS=22-$Y F JJ=1:1:SS W !
-        I $E(IOST)="C",PG>0 S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q
-        S PG=PG+1 W:$Y!($E(IOST)="C") @IOF W !,?15,"Feeder Location List For Feeder System ",EC,?72,"Page: ",PG,!!,?5,"FEEDER LOCATION",?23,"DESCRIPTION",!,LN
-        Q
+ECXFELOC ;BIR/DMA,CML-Print Feeder Locations; [ 05/07/96  8:41 AM ]
+ ;;3.0;DSS EXTRACTS;**1,8**;Dec 22, 1997
+EN ;entry point from option
+ W !!,"Print list of feeder locations.",! S QFLG=1
+ K %ZIS S %ZIS="Q" D ^%ZIS Q:POP 
+ I $D(IO("Q")) S ZTDESC="Feeder Location List (DSS)",ZTRTN="START^ECXFELOC" D ^%ZTLOAD D ^%ZISC G OUT
+ U IO
+START ;queued entry point
+ I '$D(DT) S DT=$$HTFM^XLFDT(+$H)
+ K ^TMP($J) S (QFLG,PG)=0,$P(LN,"-",81)=""
+LAB S EC=0 F  S EC=$O(^LRO(68,EC)) Q:'EC  I $D(^(EC,0)) S EC1=^(0),^TMP($J,"LAB",$P(EC1,U,11),EC)=$P(EC1,U)
+ECS S EC=0 I $P($G(^EC(720.1,1,0)),U,2) D  G IV
+ .F  S EC=$O(^ECJ(EC)) Q:'EC  I $D(^(EC,0)) S EC1=$P(^(0),"-",1,2),EC2=$P($G(^ECD(+$P(EC1,"-",2),0)),U),^TMP($J,"ECS",EC1,EC1)=EC2
+ F  S EC=$O(^ECK(EC)) Q:'EC  I $D(^(EC,0)) S EC1=$P(^(0),"-",1,2),EC2=$P($G(^ECD(+$P(EC1,"-",2),0)),U),^TMP($J,"ECS",EC1,EC1)=EC2
+IV S EC=0 F  S EC=$O(^DG(40.8,EC)) Q:'EC  I $D(^DG(40.8,EC,0)) S EC1=$E($P(^(0),U),1,30),^TMP($J,"IVP","IVP"_EC,EC)="IV Pharmacy-"_EC1
+CLI S EC=0 F  S EC=$O(^SC(EC)) Q:'EC  I $D(^(EC,0)) S EC1=^(0),ECS=$P(EC1,U,15),ECSC=$P($G(^DIC(40.7,+$P(EC1,U,7),0)),U,2),ECD=$P(EC1,U) S:'ECS ECS=1 D
+ .I $P(EC1,U,17)'="Y",$P(EC1,U,3)="C" S DAT=$G(^SC(EC,"I")),ID=+DAT,RD=$P(DAT,U,2) I 'ID!(ID>DT)!(RD&(RD<DT)) S ^TMP($J,"CLI",ECS_ECSC,EC)=ECD
+PRE I $O(^PS(59,0)) G V6
+ S EC=0 F  S EC=$O(^DIC(59,EC)) Q:'EC  I $D(^(EC,0)) S EC1=$E($P(^(0),U),1,30),^TMP($J,"PRE","PRE"_EC,EC)="Prescriptions-"_EC1
+ G RAD
+V6 S EC=0 F  S EC=$O(^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
+RAD S EC=0 F  S EC=$O(^RA(79,EC)),EC1=0 Q:'EC  I $D(^(EC,0)) S ECD=$P(^(0),U) F  S EC1=$O(^RA(79.2,EC1)) Q:'EC1  I $D(^(EC1,0)) S ECD1=$P(^(0),U),^TMP($J,"RAD",EC_"-"_EC1,EC_"-"_EC1)=ECD_"-"_ECD1
+NUR S EC=0 F  S EC=$O(^NURSF(211.4,EC)) Q:'EC  I $D(^(EC,0)) S EC1=$P(^(0),U),EC1=$P($G(^SC(+EC1,0)),U),^TMP($J,"NUR",EC,EC)=EC1
+SUR F EC=1:1:14 S EC2=$P($T(@EC),";",3) F EC1="I","A","D","M","P","C","S" S EC3=$P($T(@EC1),";",3),^TMP($J,"SUR",$P(EC2,U)_EC1,EC)=$P(EC2,U,2)_"-"_EC3
+1 ;;ORGE^GENERAL PURPOSE OPERATING ROOM
+2 ;;OROR^ORTHOPEDIC OPERATING ROOM
+3 ;;ORCA^CARDIAC OPERATING ROOM
+4 ;;ORNE^NEUROSURGERY OPERATING ROOM
+5 ;;ORCN^CARDIAC/NEURO OPERATING ROOM
+6 ;;ORAM^AMBULATORY OPERATING ROOM
+7 ;;ORIN^INTENSIVE CARE UNIT
+8 ;;OREN^ENDOSCOPY ROOM
+9 ;;ORCY^CYSTOSCOPY ROOM
+10 ;;ORWA^WARD
+11 ;;ORCL^CLINIC
+12 ;;ORDE^DEDICATED ROOM
+13 ;;OROT^OTHER LOCATION
+14 ;;ORNO^UNKNOWN
+I ;;IMPLANTS
+A ;;ANESTHESIA TIME
+D ;;SURGERY TIME (DENTAL)
+M ;;SURGERY TIME (MEDICINE)
+P ;;SURGERY TIME (PSYCH)
+C ;;SURGERY TIME (SPINAL CORD)
+S ;;SURGERY TIME (SURGERY)
+UDP S EC=0 F  S EC=$O(^DG(40.8,EC)) Q:'EC  I $D(^DG(40.8,EC,0)) S EC1=$E($P(^(0),U),1,30),^TMP($J,"UDP","UDP"_EC,EC)="Unit Dose Medications-"_EC1
+DEN S EC=0 F  S EC=$O(^DENT(225,EC)) Q:'EC  I $D(^(EC,0)) S EC1=$P(^(0),U),^TMP($J,"DEN",EC1,EC)="Dental "_EC1
+ ;
+PRINT ;
+ S EC="" F  S EC=$O(^TMP($J,EC)),EC1="" Q:EC=""  Q:QFLG  D HEAD Q:QFLG  F  S EC1=$O(^TMP($J,EC,EC1)),EC2=""  Q:EC1=""  Q:QFLG  F  S EC2=$O(^TMP($J,EC,EC1,EC2)) Q:EC2=""  Q:QFLG  D
+ .W !,?5,EC1,?23,^(EC2) I $Y+3>IOSL D HEAD Q:QFLG
+OUT I $E(IOST)="C"&('QFLG) S DIR(0)="E" D  D ^DIR K DIR
+ .S SS=22-$Y F JJ=1:1:SS W !
+ K ^TMP($J),DAT,EC,EC1,EC2,EC3,ECD,ECD1,ECS,ECSC,ID,JJ,LN,PG,POP,QFLG,RD,SS,X,Y
+ W:$E(IOST)'="C" @IOF D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" Q
+HEAD ;
+ I $E(IOST)="C" S SS=22-$Y F JJ=1:1:SS W !
+ I $E(IOST)="C",PG>0 S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q
+ S PG=PG+1 W:$Y!($E(IOST)="C") @IOF W !,?15,"Feeder Location List For Feeder System ",EC,?72,"Page: ",PG,!!,?5,"FEEDER LOCATION",?23,"DESCRIPTION",!,LN
+ Q

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXKILL.m

@@ -1 @@
-ECXKILL ;BIR/DMA,PTD-Kill Local Variables ; 5/30/2007
-        ;;3.0;DSS EXTRACTS;**9,8,21,24,31,39,49,84,89,92,105**;Dec 22, 1997;Build 70
-        ;
-        K %,%DT,%Y,%ZIS,A,A1,A2,ABR,B,BY,D,D0,D1,DA,DAT,DATA,DATA1,DATA2,DATA6
-        K DATAOP,DD,DFN,DHDH,DIC,DIE,DIK,DINUM,DIQ
-        K ECDAPRNP,ECDPRNPI,ECISNPI,ECDOCNPI
-        K ECU1NPI,ECU2NPI,ECU3NPI
-        K DIR,DIRUT,DO,DR,DTOUT,DUOUT,EC,EC0,EC1,EC10,EC11,EC16,EC2,EC23,EC2NODE
-        K EC3,EC42,EC50,EC6,EC7,ECA,ECAC,ECACA,ECAD,ECADM,ECALL
-        K ECANE,ECAO,ECARG,ECAS,ECAT,ECATSV,ECB,ECC,ECCA,ECCAN,ECCAT,ECCH,ECCN
-        K ECCNT,ECCS,ECCSC,ECD,ECD0,ECD1,ECDA,ECDAL,ECDAT
-        K ECDATA,ECDATA1,ECDATE,ECDEN,ECDEX,ECDF,ECDFN,ECDFN0,ECDI,ECDIA,ECDIF
-        K ECDIV,ECDL,ECDN,ECDNEW,ECDO,ECDOC,ECDR,ECDRG,ECDS,ECDSSU,ECDT,ECDTTM
-        K ECDU,ECEC0,ECED,ECED1,ECEDN,ECEDNEW,ECF,ECF1,ECFD,ECFDT,ECFILE,ECFK
-        K ECFL,ECFR,ECGRP,ECH,ECHD,ECHEAD,ECI,ECID,ECIEN,ECIFN,ECIN
-        K ECINST,ECINV,ECIV,ECJ,ECK,ECL,ECL1,ECLAN,ECLAST,ECLDT,ECLINK,ECLIST
-        K ECLL,ECLN,ECLOC,ECLRN,ECLX,ECLY,ECM,ECMAX,ECMIN
-        K ECXMISS,ECMN,ECMOD,ECMODS,ECMORE,ECMS,ECMSG,ECMSN,ECMT,ECMW,ECMY,ECN
-        K ECNA,ECNDC,ECNDF,ECNFC,ECNL,ECNO,ECNODE,ECNOGO
-        K ECNT,ECO,ECO0,ECO1,ECO2,ECOB,ECODE,ECODE0,ECODE1,ECODE2,ECOLD,ECONE,ECOPAY
-        K ECATTNPI,ECPWNPI,ECXUSNPI,ECPWNPI,ECXOEF,ECXOEFDT,ECPLACE
-        K ECOPAYT,ECORTY,ECOS,ECP,ECPACK,ECPCE,ECPCE1,ECPCE2,ECPCE3,ECPCE4
-        K ECPCE5,ECPCE6,ECPCE7,ECPIECE,ECPN,ECPRC,ECPRO,ECODE2
-        K ECPROF,ECPT,ECPTF,ECPTPR,ECPTTM,ECQ,ECQT,ECQTY,ECRD,ECRE,ECRED,ECREF
-        K ECRFL,ECRN,ECROU,ECRR,ECRS,ECRSD,ECRTN,ECRX,ECS,ECSA,ECSC
-        K ECSD,ECSD1,ECSDN,ECSN,ECSR,ECSS,ECST,ECSTOP,ECSU,ECT,ECT1,ECTD,ECTD1
-        K ECTEMP,ECTM,ECTNTL,ECTOTAL,ECTREAT,ECTRT,ECTS,ECTY,ECXLOGIC,ECXDATES,ECXEST,ECXECE
-        D ^ECXKILL1
-        ;
-AUDIT   ;kill audit report variables, close slave printer
-        K %DT,ECX,ECXARRAY,ECXACC,ECXALL,ECXAUD,ECXCODE,ECXD,ECXDEF,ECXDESC,ECXDIV
-        K ECXRCST,ECXRQST,ECXEND,ECXERR,ECXEXT,ECXHEAD,ECXLOC,ECXPGM,ECXPHCPC
-        K ECXPRIME,ECXPRO,ECXREPT,ECXRUN,ECXSAVE,ECXSTART,ECXSRCE
-        K ECXCTAMT,ECXFEKEY,ECXFELOC,ECXFORM,ECXGRPR,ECXHCPC,ECXPHCPC,ECXHCPCS
-        K ECXLAB,ECXLLC,ECXLMC,ECXQTY,ECXREQ,ECXSTAT,ECXTYPE
-        K IO("Q"),POP,DIR,DIC,DIE,DA,DR,DO,DIRUT,DUOUT,DTOUT
-        K ^TMP($J)
-        I IO=IO(0),IOST'="C" D ^%ZISC
-        Q
+ECXKILL ;BIR/DMA,PTD-Kill Local Variables ; 9/13/05 10:24am
+ ;;3.0;DSS EXTRACTS;**9,8,21,24,31,39,49,84,89**;Dec 22, 1997
+ ;
+ K %,%DT,%Y,%ZIS,A,A1,A2,ABR,B,BY,D,D0,D1,DA,DAT,DATA,DATA1,DATA2,DATA6
+ K DATAOP,DD,DFN,DHDH,DIC,DIE,DIK,DINUM,DIQ
+ K DIR,DIRUT,DO,DR,DTOUT,DUOUT,EC,EC0,EC1,EC10,EC11,EC16,EC2,EC23,EC2NODE
+ K EC3,EC42,EC50,EC6,EC7,ECA,ECAC,ECACA,ECAD,ECADM,ECALL
+ K ECANE,ECAO,ECARG,ECAS,ECAT,ECATSV,ECB,ECC,ECCA,ECCAN,ECCAT,ECCH,ECCN
+ K ECCNT,ECCS,ECCSC,ECD,ECD0,ECD1,ECDA,ECDAL,ECDAT
+ K ECDATA,ECDATA1,ECDATE,ECDEN,ECDEX,ECDF,ECDFN,ECDFN0,ECDI,ECDIA,ECDIF
+ K ECDIV,ECDL,ECDN,ECDNEW,ECDO,ECDOC,ECDR,ECDRG,ECDS,ECDSSU,ECDT,ECDTTM
+ K ECDU,ECEC0,ECED,ECED1,ECEDN,ECEDNEW,ECF,ECF1,ECFD,ECFDT,ECFILE,ECFK
+ K ECFL,ECFR,ECGRP,ECH,ECHD,ECHEAD,ECI,ECID,ECIEN,ECIFN,ECIN
+ K ECINST,ECINV,ECIV,ECJ,ECK,ECL,ECL1,ECLAN,ECLAST,ECLDT,ECLINK,ECLIST
+ K ECLL,ECLN,ECLOC,ECLRN,ECLX,ECLY,ECM,ECMAX,ECMIN
+ K ECXMISS,ECMN,ECMOD,ECMODS,ECMORE,ECMS,ECMSG,ECMSN,ECMT,ECMW,ECMY,ECN
+ K ECNA,ECNDC,ECNDF,ECNFC,ECNL,ECNO,ECNODE,ECNOGO
+ K ECNT,ECO,ECO0,ECO1,ECO2,ECOB,ECODE,ECODE0,ECODE1,ECOLD,ECONE,ECOPAY
+ K ECOPAYT,ECORTY,ECOS,ECP,ECPACK,ECPCE,ECPCE1,ECPCE2,ECPCE3,ECPCE4
+ K ECPCE5,ECPCE6,ECPCE7,ECPIECE,ECPN,ECPRC,ECPRO,ECODE2
+ K ECPROF,ECPT,ECPTF,ECPTPR,ECPTTM,ECQ,ECQT,ECQTY,ECRD,ECRE,ECRED,ECREF
+ K ECRFL,ECRN,ECROU,ECRR,ECRS,ECRSD,ECRTN,ECRX,ECS,ECSA,ECSC
+ K ECSD,ECSD1,ECSDN,ECSN,ECSR,ECSS,ECST,ECSTOP,ECSU,ECT,ECT1,ECTD,ECTD1
+ K ECTEMP,ECTM,ECTNTL,ECTOTAL,ECTREAT,ECTRT,ECTS,ECTY,ECXLOGIC,ECXDATES,ECXEST,ECXECE
+ D ^ECXKILL1
+ ;
+AUDIT ;kill audit report variables, close slave printer
+ K ECX,ECXARRAY,ECXACC,ECXALL,ECXAUD,ECXCODE,ECXD,ECXDEF,ECXDESC,ECXDIV
+ K ECXRCST,ECXRQST,ECXEND,ECXERR,ECXEXT,ECXHEAD,ECXLOC,ECXPGM,ECXPHCPC
+ K ECXPRIME,ECXPRO,ECXREPT,ECXRUN,ECXSAVE,ECXSTART,ECXSRCE
+ K ECXCTAMT,ECXFEKEY,ECXFELOC,ECXFORM,ECXGRPR,ECXHCPC,ECXPHCPC,ECXHCPCS
+ K ECXLAB,ECXLLC,ECXLMC,ECXQTY,ECXREQ,ECXSTAT,ECXTYPE
+ K IO("Q"),POP,DIR,DIC,DIE,DA,DR,DO,DIRUT,DUOUT,DTOUT
+ K ^TMP($J)
+ I IO=IO(0),IOST'="C" D ^%ZISC
+ Q

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXLABN.m

@@ -1 @@
-ECXLABN ;ALB/JAP,BIR/CML-Lab Extract for DSS (New Format - With LMIP Codes) ; 10/23/07 3:01pm
-        ;;3.0;DSS EXTRACTS;**1,11,8,13,28,24,30,31,32,33,39,42,46,70,71,80,92,107,105**;Dec 22, 1997;Build 70
-BEG     ;entry point
-        D SETUP I ECFILE="" Q
-        D ^ECXTRAC,^ECXKILL
-        Q
-        ;
-START   ; entry when queued
-        K ^LRO(64.03),^TMP($J,"ECXP")
-        N ECDOCPC
-        S LRSDT=ECSD,LREDT=ECED,QFLG=0
-        D ^LRCAPDSS
-        ;quit if no completion date for API compile
-        I '$P($G(^LRO(64.03,1,1,1,0)),U,4) Q
-        ;quit if tasked and user sends stop request
-        I $D(ZTQUEUED),$$S^%ZTLOAD D  Q
-        .S QFLG=1
-        .K ^LRO(64.03) S ^LRO(64.03,0)="WKLD LOG FILE^64.03^"
-        ;otherwise, continue
-        K ECXDD D FIELD^DID(64.03,1,,"SPECIFIER","ECXDD")
-        S ECPROF=$E(+$P(ECXDD("SPECIFIER"),"P",2)),ECLRN=1 K ECXDD
-        F  S ECLRN=$O(^LRO(64.03,ECLRN)) Q:'ECLRN  D  Q:QFLG
-        .Q:'$D(^LRO(64.03,ECLRN,0))
-        .S EC1=^LRO(64.03,ECLRN,0),ECDOC=ECPROF_$P(EC1,U,2)
-        .S ECDOCNPI=$$NPI^XUSNPI("Individual_ID",$P(EC1,U,2),$P(EC1,U,4))
-        .S:+ECDOCNPI'>0 ECDOCNPI="" S ECDOCNPI=$P(ECDOCNPI,U)
-        .S ECLOC=$P(EC1,U,15),EC=$P(EC1,U,3),ECDOCPC=$$PRVCLASS^ECXUTL($P(EC1,U,2),$P(EC1,U,4))
-        .I EC]"" D GET
-        K ^LRO(64.03),^TMP($J,"ECXP") S ^LRO(64.03,0)="WKLD LOG FILE^64.03^"
-        K ECDOCNPI,ECXAGC,ECXL1,ECXL2
-        Q
-        ;
-GET     ;get data
-        N X,ECXSTN,QFLAG
-        S ECF=$S($P(EC,";",2)="DPT(":2,$P(EC,";",2)="LRT(67,":67,1:0) Q:'ECF
-        S ECIFN=$P(EC,";"),QFLAG=0
-        ;resolve ecloc
-        S ECXL1=+$P(ECLOC,";",1),ECXL2=$P(ECLOC,";",2)
-        I ECF=2 S ECLOC=$S(ECXL1>0:ECXL1,1:"") I ECXL2]"",ECXL2'="SC(" S ECLOC=""
-        I ECF=67 D  S ECLOC=ECXSTN
-        .S (ECXSTN,ECXAGC)=""
-        .I (ECXL2'="DIC(4,")!('$D(^DIC(4,ECXL1))) S ECXSTN="XXXXX",ECXAGC="XX" Q
-        .S ECXSTN=$P(^DIC(4,ECXL1,"99"),U,1),ECXAGC=$E($P(^(99),U,5),1,2)
-        .S:ECXSTN="" ECXSTN="ZZZZZ" S:ECXAGC="" ECXAGC="ZZ"
-        S ECDT=$P(EC1,U,13),ECD=$P(ECDT,"."),ECTM=$$ECXTIME^ECXUTL(ECDT)
-        S ECWKLD=$P(EC1,U,11),ECWK="" I $D(^LAM(ECWKLD,0)) S ECWK=$P(^(0),U,2)
-        S (ECXADMDT,ECTREAT,ECNA,ECSN,ECMN,ECPTTM,ECPTPR,ECCLAS)="",ECA="O",ECXERR=0
-        S (ECPTNPI,ECASPR,ECCLAS2,ECASNPI)=""
-        ;get the patient data if record is in file #2
-        I ECF=2 D PAT(ECIFN,ECDT,.ECXERR)
-        Q:ECXERR
-        ;get patient data if record is in file #67
-        I ECF=67 S ECSN="000123456",ECNA="RFRL" I $D(^LRT(67,ECIFN,0)) D  Q:QFLAG
-        .S ECXMPI="",EC0=^LRT(67,ECIFN,0),ECNA=$E($P($P(EC0,U),",")_"    ",1,4)
-        .S ECSN=$P(EC0,U,9),ECXERI="" D
-        ..S ECNA=$TR(ECNA,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
-        ..I ECSN="" S ECSN="000123456" Q
-        ..S ECSN=$TR(ECSN," "),ECSN=$TR(ECSN,"-")
-        ..I ($L(ECSN)<9)!($L(ECSN)>10) S ECSN="000123456" Q
-        ..I $L(ECSN)=9,ECSN'?9N S ECSN="000123456" Q
-        ..I $L(ECSN)=10,ECSN'?9N1"P" S ECSN="000123456"
-        ..I '$$SSN^ECXUTL5(ECSN,ECF) S QFLAG=1
-        ;
-        ;- Only set treating spec (TS) to TS in file #64.03 if it does not exist
-        I ECA="I",ECTREAT="" S ECTREAT=$P($G(^DIC(45.7,+$P(EC1,U,10),0)),U,2)
-        S (ECXDOM,ECXDSSD)=""
-        S X=$G(^ECX(727.831,+ECTREAT,0)) S:X'="" ECXDOM=$P(X,U,2)
-        ;
-        ;- Get ordering stop code and ordering date
-        S ECXORDST=+$P(EC1,U,15),ECXORDST=$S(ECXORDST:$P($G(^ECX(728.44,ECXORDST,0)),U,2),1:"")
-        S ECXORDDT=$S($P(EC1,U,14):$$ECXDATE^ECXUTL($P(EC1,U,14),ECXYM),1:"")
-        ;
-        ;- Get Production Division - ECXDIEN added p-80
-        N ECXPDIV,ECXDIEN S ECXDIEN=$O(^DIC(4,"D",ECINST,"")),ECXPDIV=$$RADDIV^ECXDEPT(ECXDIEN)  ;P-46
-        K ECXDIEN
-        ;
-        ;- Observation patient indicator (YES/NO)
-        S ECXOBS=$$OBSPAT^ECXUTL4(ECA,ECTREAT)
-        ;
-        ;- If no encounter number don't file record
-        S ECXENC=$$ENCNUM^ECXUTL4(ECA,ECSN,ECXADMDT,ECD,ECTREAT,ECXOBS,ECHEAD,,) Q:ECXENC=""
-        ;create extract record only if patient name and accession area exist
-        I ECNA]"" S ECT=$P(EC1,U,8),ECURG=$P(EC1,U,9),EC=+$P(EC1,U,7) I EC D
-        .S:ECF=2 ECACA=EC_U_$P($G(^LRO(68,EC,0)),U,11)
-        .S:ECF=67 ECACA=ECXAGC_U_$P($G(^LRO(68,EC,0)),U,11)
-        .D FILE
-        Q
-        ;
-PAT(ECXDFN,ECXDATE,ECXERR)      ;get/set patient data
-        N X,OK,PT
-        ;get data
-        I $D(^TMP($J,"ECXP",ECXDFN)) D
-        .S PT=^TMP($J,"ECXP",ECXDFN),ECNA=$P(PT,U)
-        .S ECSN=$P(PT,U,2),ECXMPI=$P(PT,U,3),ECXERI=$P(PT,U,4)
-        ;set data and save for later
-        I '$D(^TMP($J,"ECXP",ECXDFN)) D  Q:'OK
-        .K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECSD,"."),"1;3",.ECXPAT)
-        .I 'OK S ECXERR=1 Q
-        .S ECNA=ECXPAT("NAME"),ECSN=ECXPAT("SSN"),ECXMPI=ECXPAT("MPI")
-        .S ECXERI=ECXPAT("ERI")
-        .S ^TMP($J,"ECXP",ECXDFN)=ECNA_U_ECSN_U_ECXMPI_U_ECXERI
-        ;get date specific data
-        S X=$$INP^ECXUTL2(ECXDFN,ECXDATE),ECA=$P(X,U),ECMN=$P(X,U,2),ECTREAT=$P(X,U,3),ECXADMDT=$P(X,U,4)
-        S X=$$PRIMARY^ECXUTL2(ECXDFN,$P(ECXDATE,"."),ECPROF)
-        S ECPTTM=$P(X,U,1),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4)
-        S ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7)
-        Q
-        ;
-FILE    ;file record
-        ;node0
-        ;facility^patient number^SSN (or equivalent)^name^in/out ECA^
-        ;day^accession area^abbreviation^test^urgency^treating spec^
-        ;location^provider and file^
-        ;movement number^file^time^workload code^primary care team^
-        ;primary care provider
-        ;node1
-        ;mpi^dss dept^provider npi^pc provider npi^pc prov person class^
-        ;assoc pc prov^assoc pc prov person class^assoc pc prov npi^
-        ;dom ECXDOM^observ pat ind ECXOBS^encounter num ECXENC^
-        ;ord stop code ECXORDST^ord date ECXORDDT^production division
-        ;ECXPDIV^^ordering provider person class^emergency response indicator
-        ;(FEMA) ECXERI^associate pc provider npi ECASNPI^primary care provider
-        ;npi ECPTNPI^provider npi ECDOCNPI
-        ;ECDOCPC
-        N DA,DIK
-        S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1
-        S ECODE=EC7_U_EC23_U_ECINST_U_ECIFN_U_ECSN_U_ECNA_U_ECA_U
-        S ECODE=ECODE_$$ECXDATE^ECXUTL(ECD,ECXYM)_U_ECACA_U_ECT_U_ECURG_U
-        ;convert specialty to PTF Code for transmission
-        N ECXDATA
-        S ECXDATA=$$TSDATA^DGACT(42.4,+ECTREAT,.ECXDATA)
-        S ECTREAT=$G(ECXDATA(7))
-        ;done
-        S ECODE=ECODE_ECTREAT_U_ECLOC_U_ECDOC_U_ECMN_U_ECF_U_ECTM_U_ECWK_U
-        S ECODE=ECODE_ECPTTM_U_ECPTPR_U
-        ;(ECACA=acc area^abbreviation)
-        S ECODE1=ECXMPI_U_ECXDSSD_U_U_U_ECCLAS_U_ECASPR_U
-        S ECODE1=ECODE1_ECCLAS2_U_U_ECXDOM_U_ECXOBS_U_ECXENC_U
-        S ECODE1=ECODE1_ECXORDST_U_ECXORDDT_U_ECXPDIV_U
-        I ECXLOGIC>2004 S ECODE1=ECODE1_U_ECDOCPC
-        I ECXLOGIC>2006 S ECODE1=ECODE1_U_ECXERI
-        I ECXLOGIC>2007 S ECODE1=ECODE1_U_ECASNPI_U_ECPTNPI_U_ECDOCNPI
-        S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,ECRN=ECRN+1
-        S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA
-        I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1
-        Q
-        ;
-SETUP   ;Set required input for ECXTRAC
-        S ECHEAD="LAB"
-        D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
-        Q
-        ;
-QUE     ; entry point for the background requeuing handled by ECXTAUTO
-        D SETUP,QUE^ECXTAUTO,^ECXKILL Q
+ECXLABN ;ALB/JAP,BIR/CML-Lab Extract for DSS (New Format - With LMIP Codes) ; 4/25/07 8:52am
+ ;;3.0;DSS EXTRACTS;**1,11,8,13,28,24,30,31,32,33,39,42,46,70,71,80,92,107**;Dec 22, 1997;Build 9
+BEG ;entry point
+ D SETUP I ECFILE="" Q
+ D ^ECXTRAC,^ECXKILL
+ Q
+ ;
+START ; entry when queued
+ K ^LRO(64.03),^TMP($J,"ECXP")
+ N ECDOCPC
+ S LRSDT=ECSD,LREDT=ECED,QFLG=0
+ D ^LRCAPDSS
+ ;quit if no completion date for API compile
+ I '$P($G(^LRO(64.03,1,1,1,0)),U,4) Q
+ ;quit if tasked and user sends stop request
+ I $D(ZTQUEUED),$$S^%ZTLOAD D  Q
+ .S QFLG=1
+ .K ^LRO(64.03) S ^LRO(64.03,0)="WKLD LOG FILE^64.03^"
+ ;otherwise, continue
+ K ECXDD D FIELD^DID(64.03,1,,"SPECIFIER","ECXDD")
+ S ECPROF=$E(+$P(ECXDD("SPECIFIER"),"P",2)),ECLRN=1 K ECXDD
+ F  S ECLRN=$O(^LRO(64.03,ECLRN)) Q:'ECLRN  D  Q:QFLG
+ .Q:'$D(^LRO(64.03,ECLRN,0))
+ .S EC1=^LRO(64.03,ECLRN,0),ECDOC=ECPROF_$P(EC1,U,2),ECDOCNPI=""
+ .S ECLOC=$P(EC1,U,15),EC=$P(EC1,U,3),ECDOCPC=$$PRVCLASS^ECXUTL($P(EC1,U,2),$P(EC1,U,4))
+ .I EC]"" D GET
+ K ^LRO(64.03),^TMP($J,"ECXP") S ^LRO(64.03,0)="WKLD LOG FILE^64.03^"
+ K ECDOCNPI,ECXAGC,ECXL1,ECXL2
+ Q
+ ;
+GET ;get data
+ N X,ECXSTN
+ S ECF=$S($P(EC,";",2)="DPT(":2,$P(EC,";",2)="LRT(67,":67,1:0) Q:'ECF
+ S ECIFN=$P(EC,";")
+ ;resolve ecloc
+ S ECXL1=+$P(ECLOC,";",1),ECXL2=$P(ECLOC,";",2)
+ I ECF=2 S ECLOC=$S(ECXL1>0:ECXL1,1:"") I ECXL2]"",ECXL2'="SC(" S ECLOC=""
+ I ECF=67 D  S ECLOC=ECXSTN
+ .S (ECXSTN,ECXAGC)=""
+ .I (ECXL2'="DIC(4,")!('$D(^DIC(4,ECXL1))) S ECXSTN="XXXXX",ECXAGC="XX" Q
+ .S ECXSTN=$P(^DIC(4,ECXL1,"99"),U,1),ECXAGC=$E($P(^(99),U,5),1,2)
+ .S:ECXSTN="" ECXSTN="ZZZZZ" S:ECXAGC="" ECXAGC="ZZ"
+ S ECDT=$P(EC1,U,13),ECD=$P(ECDT,"."),ECTM=$$ECXTIME^ECXUTL(ECDT)
+ S ECWKLD=$P(EC1,U,11),ECWK="" I $D(^LAM(ECWKLD,0)) S ECWK=$P(^(0),U,2)
+ S (ECXADMDT,ECTREAT,ECNA,ECSN,ECMN,ECPTTM,ECPTPR,ECCLAS)="",ECA="O",ECXERR=0
+ S (ECPTNPI,ECASPR,ECCLAS2,ECASNPI)=""
+ ;get the patient data if record is in file #2
+ I ECF=2 D PAT(ECIFN,ECDT,.ECXERR)
+ Q:ECXERR
+ ;get patient data if record is in file #67
+ I ECF=67 S ECSN="000123456",ECNA="RFRL" I $D(^LRT(67,ECIFN,0)) D
+ .S ECXMPI="",EC0=^LRT(67,ECIFN,0),ECNA=$E($P($P(EC0,U),",")_"    ",1,4)
+ .S ECSN=$P(EC0,U,9),ECXERI="" D
+ ..S ECNA=$TR(ECNA,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+ ..I ECSN="" S ECSN="000123456" Q
+ ..S ECSN=$TR(ECSN," "),ECSN=$TR(ECSN,"-")
+ ..I ($L(ECSN)<9)!($L(ECSN)>10) S ECSN="000123456" Q
+ ..I $L(ECSN)=9,ECSN'?9N S ECSN="000123456" Q
+ ..I $L(ECSN)=10,ECSN'?9N1"P" S ECSN="000123456"
+ ;
+ ;- Only set treating spec (TS) to TS in file #64.03 if it does not exist
+ I ECA="I",ECTREAT="" S ECTREAT=$P($G(^DIC(45.7,+$P(EC1,U,10),0)),U,2)
+ S (ECXDOM,ECXDSSD)=""
+ S X=$G(^ECX(727.831,+ECTREAT,0)) S:X'="" ECXDOM=$P(X,U,2)
+ ;
+ ;- Get ordering stop code and ordering date
+ S ECXORDST=+$P(EC1,U,15),ECXORDST=$S(ECXORDST:$P($G(^ECX(728.44,ECXORDST,0)),U,2),1:"")
+ S ECXORDDT=$S($P(EC1,U,14):$$ECXDATE^ECXUTL($P(EC1,U,14),ECXYM),1:"")
+ ;
+ ;- Get Production Division - ECXDIEN added p-80
+ N ECXPDIV,ECXDIEN S ECXDIEN=$O(^DIC(4,"D",ECINST,"")),ECXPDIV=$$RADDIV^ECXDEPT(ECXDIEN)  ;P-46
+ K ECXDIEN
+ ;
+ ;- Observation patient indicator (YES/NO)
+ S ECXOBS=$$OBSPAT^ECXUTL4(ECA,ECTREAT)
+ ;
+ ;- If no encounter number don't file record
+ S ECXENC=$$ENCNUM^ECXUTL4(ECA,ECSN,ECXADMDT,ECD,ECTREAT,ECXOBS,ECHEAD,,) Q:ECXENC=""
+ ;create extract record only if patient name and accession area exist
+ I ECNA]"" S ECT=$P(EC1,U,8),ECURG=$P(EC1,U,9),EC=+$P(EC1,U,7) I EC D
+ .S:ECF=2 ECACA=EC_U_$P($G(^LRO(68,EC,0)),U,11)
+ .S:ECF=67 ECACA=ECXAGC_U_$P($G(^LRO(68,EC,0)),U,11)
+ .D FILE
+ Q
+ ;
+PAT(ECXDFN,ECXDATE,ECXERR) ;get/set patient data
+ N X,OK,PT
+ ;get data
+ I $D(^TMP($J,"ECXP",ECXDFN)) D
+ .S PT=^TMP($J,"ECXP",ECXDFN),ECNA=$P(PT,U)
+ .S ECSN=$P(PT,U,2),ECXMPI=$P(PT,U,3),ECXERI=$P(PT,U,4)
+ ;set data and save for later
+ I '$D(^TMP($J,"ECXP",ECXDFN)) D  Q:'OK
+ .K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECSD,"."),"1;3",.ECXPAT)
+ .I 'OK S ECXERR=1 Q
+ .S ECNA=ECXPAT("NAME"),ECSN=ECXPAT("SSN"),ECXMPI=ECXPAT("MPI")
+ .S ECXERI=ECXPAT("ERI")
+ .S ^TMP($J,"ECXP",ECXDFN)=ECNA_U_ECSN_U_ECXMPI_U_ECXERI
+ ;get date specific data
+ S X=$$INP^ECXUTL2(ECXDFN,ECXDATE),ECA=$P(X,U),ECMN=$P(X,U,2),ECTREAT=$P(X,U,3),ECXADMDT=$P(X,U,4)
+ S X=$$PRIMARY^ECXUTL2(ECXDFN,$P(ECXDATE,"."),ECPROF)
+ S ECPTTM=$P(X,U,1),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4)
+ S ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7)
+ Q
+ ;
+FILE ;file record
+ ;node0
+ ;facility^patient number^SSN (or equivalent)^name^in/out ECA^
+ ;day^accession area^abbreviation^test^urgency^treating spec^
+ ;location^provider and file^
+ ;movement number^file^time^workload code^primary care team^
+ ;primary care provider
+ ;node1
+ ;mpi^dss dept^provider npi^pc provider npi^pc prov person class^
+ ;assoc pc prov^assoc pc prov person class^assoc pc prov npi^
+ ;dom ECXDOM^observ pat ind ECXOBS^encounter num ECXENC^
+ ;ord stop code ECXORDST^ord date ECXORDDT^production division
+ ;ECXPDIV^^ordering provider person class^emergency response indicator
+ ;(FEMA) ECXERI
+ ;ECDOCPC
+ N DA,DIK
+ S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1
+ S ECODE=EC7_U_EC23_U_ECINST_U_ECIFN_U_ECSN_U_ECNA_U_ECA_U
+ S ECODE=ECODE_$$ECXDATE^ECXUTL(ECD,ECXYM)_U_ECACA_U_ECT_U_ECURG_U
+ ;convert specialty to PTF Code for transmission
+ N ECXDATA
+ S ECXDATA=$$TSDATA^DGACT(42.4,+ECTREAT,.ECXDATA)
+ S ECTREAT=$G(ECXDATA(7))
+ ;done
+ S ECODE=ECODE_ECTREAT_U_ECLOC_U_ECDOC_U_ECMN_U_ECF_U_ECTM_U_ECWK_U
+ S ECODE=ECODE_ECPTTM_U_ECPTPR_U
+ ;(ECACA=acc area^abbreviation)
+ S ECODE1=ECXMPI_U_ECXDSSD_U_ECDOCNPI_U_ECPTNPI_U_ECCLAS_U_ECASPR_U
+ S ECODE1=ECODE1_ECCLAS2_U_ECASNPI_U_ECXDOM_U_ECXOBS_U_ECXENC_U
+ S ECODE1=ECODE1_ECXORDST_U_ECXORDDT_U_ECXPDIV_U
+ I ECXLOGIC>2004 S ECODE1=ECODE1_U_ECDOCPC
+ I ECXLOGIC>2006 S ECODE1=ECODE1_U_ECXERI
+ S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,ECRN=ECRN+1
+ S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA
+ I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1
+ Q
+ ;
+SETUP ;Set required input for ECXTRAC
+ S ECHEAD="LAB"
+ D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
+ Q
+ ;
+QUE ; entry point for the background requeuing handled by ECXTAUTO
+ D SETUP,QUE^ECXTAUTO,^ECXKILL Q

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXLABR.m

@@ -1 @@
-ECXLABR ;ALB/JAP,BIR/CML-LAR Extract for DSS (New Format - With LMIP Codes) ; 6/5/07 2:33pm
-        ;;3.0;DSS EXTRACTS;**8,24,33,37,39,46,71,80,107,105**;Dec 22, 1997;Build 70
-BEG     ;entry point from option
-        D SETUP I ECFILE="" Q
-        D ^ECXTRAC,^ECXKILL
-        Q
-        ;
-START   ; entry when queued
-        N X,OK,ECTRS,ECTRANS,ECTRIEN,ECDOC,ECDOCPC
-        K ^LAR(64.036) S LRSDT=ECSD,LREDT=ECED
-        D ^LRCAPDAR
-        ;quit if no completion date for API compile
-        I '$P($G(^LAR(64.036,1,2,1,0)),U,4) Q
-        ;build local array of workload codes for local lab tests linked to
-        ;DSS tests
-        K ECLOC S ECDTST=0
-        F  S ECDTST=$O(^ECX(727.2,1,1,ECDTST)) Q:('ECDTST)  S ECLTST=0 D
-        .F  S ECLTST=$O(^ECX(727.2,1,1,ECDTST,"LOC",ECLTST)) Q:'ECLTST  D
-        ..S ECLTIEN=+^ECX(727.2,1,1,ECDTST,"LOC",ECLTST,0)
-        ..S ECWCDA=+$G(^LAB(60,ECLTIEN,64))
-        ..I ECWCDA S ECWC=$P(^LAM(ECWCDA,0),U,2),ECLOC(ECWCDA)=ECWC
-        K ECLTIEN
-        ;process temporary lab file #64.036
-        S QFLG=0,ECLRN=1
-        F  S ECLRN=$O(^LAR(64.036,ECLRN)) Q:('ECLRN)!(QFLG)  D
-        .I $D(^LAR(64.036,ECLRN,0))  D
-        ..S EC1=^LAR(64.036,ECLRN,0),ECF=$P(EC1,U,2)
-        ..Q:ECF=""
-        ..S ECXDFN=$P(EC1,U,3),ECPTPR=$P($G(EC1),U,11),ECCLASS=""
-        ..S ECXTIME=$S($P(EC1,U,10)="":"000300",1:$P(EC1,U,10))
-        ..S ECXDATE=$P(EC1,U,9)_"."_$P(EC1,U,10)
-        ..I ECPTPR S ECCLASS=$$PRVCLASS^ECXUTL(ECPTPR,ECXDATE)
-        ..I ECPTPR S ECPTNPI=$$NPI^XUSNPI("Individual_ID",ECPTPR,+ECXDATE) D
-        ...S:+ECPTNPI'>0 ECPTNPI="" S ECPTNPI=$P(ECPTNPI,U)
-        ..S ECORDT=$$ECXDATE^ECXUTL($P(EC1,U,4),ECXYM)
-        ..S ECORTM=$$ECXTIME^ECXUTL($P(EC1,U,4)_"."_$P(EC1,U,5))
-        ..S ECREDT=$$ECXDATE^ECXUTL($P(EC1,U,6),ECXYM)
-        ..S ECRETM=$$ECXTIME^ECXUTL($P(EC1,U,6)_"."_$P(EC1,U,7))
-        ..S ECSCDT=$$ECXDATE^ECXUTL($P(EC1,U,9),ECXYM)
-        ..S ECSCTM=$$ECXTIME^ECXUTL($P(EC1,U,9)_"."_$P(EC1,U,10))
-        ..S (ECXADMDT,ECXDOM,ECXDSSD,ECXPNM,ECXSSN,ECXA,ECXMN,ECXTS)=""
-        ..I ECF=2 D  Q:'OK
-        ...K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,ECXDATE,"1;",.ECXPAT)
-        ...Q:'OK
-        ...S ECXPNM=ECXPAT("NAME"),ECXSSN=ECXPAT("SSN"),ECXMPI=ECXPAT("MPI")
-        ...S X=$$INP^ECXUTL2(ECXDFN,ECXDATE),ECXA=$P(X,U),ECXADMDT=$P(X,U,4)
-        ...S ECXMN=$P(X,U,2),ECXTS=$P(X,U,3),ECXDOM=$P(X,U,10)
-        ..;allow for referral patients in future??
-        ..;I ECF=67 S ECSN="000123456",ECNA="RFRL"
-        ..;loop on results multiple
-        ..;
-        ..;Get production division ECXDIEN added p-80
-        ..N ECXPDIV,ECXDIEN S ECXDIEN=$O(^DIC(4,"D",ECINST,"")),ECXPDIV=$$RADDIV^ECXDEPT(ECXDIEN) ;p-46
-        ..K ECXDIEN
-        ..;- Observation patient indicator (y/n)
-        ..S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS)
-        ..;
-        ..;- If no encounter number don't file record
-        ..S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,$P(EC1,U,9),ECXTS,ECXOBS,ECHEAD,,) Q:ECXENC=""
-        ..S ECRES=0
-        ..F  S ECRES=$O(^LAR(64.036,ECLRN,1,ECRES)) Q:('ECRES)!(QFLG)  D
-        ...I $D(^LAR(64.036,ECLRN,1,ECRES,0)) D  Q:QFLG
-        ....S EC2=^LAR(64.036,ECLRN,1,ECRES,0),ECN=$P(EC2,U),ECRS=$P(EC2,U,2)
-        ....S ECHL=$E($P(EC2,U,3)),ECWC=+$P(EC2,U,4)
-        ....S ECWC=$S($D(ECLOC(ECWC)):ECLOC(ECWC),1:"")
-        ....;
-        ....; - Free text results translation
-        ....S ECTRANS="",ECTRS=ECRS
-        ....I +ECTRS S ECTRS=$TR(ECTRS,",","") D
-        .....I (ECTRS?.N)!(ECTRS?.N1".".N) S ECRS=ECTRS
-        ....F  Q:$E(ECTRS,1)'=" "  S ECTRS=$E(ECTRS,2,$L(ECTRS))
-        ....F  Q:$E(ECTRS,$L(ECTRS))'=" "  S ECTRS=$E(ECTRS,1,($L(ECTRS)-1))
-        ....I ECTRS]"" I ECTRS'?.N I ECTRS'?.N1".".N D  ;translate
-        .....S ECTRS=$TR(ECRS,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
-        .....S ECTRIEN="",ECTRIEN=$O(^ECX(727.7,"B",ECTRS,ECTRIEN))
-        .....S ECTRANS=$S(ECTRIEN:$P(^ECX(727.7,ECTRIEN,0),U,2),1:5)
-        ....;
-        ....I ECWC]"" D FILE
-        K ^LAR(64.036) S ^LAR(64.036,0)="LAB DSS LAR EXTRACT^64.036^"
-        Q
-        ;
-FILE    ;file record
-        ;node0
-        ;facility (ECINST)^dfn (ECXDFN)^ssn (ECXSSN)^name(ECXPNM)^in/out (ECXA)^
-        ;day(ECSCDT)^
-        ;lab test code (ECN)^results (ECRS)^hi/lo indicator (ECHL)^
-        ;date ordered (ECORDT)^time ordered (ECORTM)^date ready (ECREDT)^
-        ;time ready (ECRETM)^
-        ;movement file # (ECXMN)^treating specialty (ECXTS)^
-        ;workload code(ECWC)^
-        ;node1
-        ;mpi (ECXMPI)^dss dept (ECXDSSD)^dom (ECXDOM)^time (ECSCTM)^
-        ;observ pat ind (ECXOBS)^encounter num (ECXENC)^prod div ECXPDIV^
-        ;lab results translation ECXTRANS^ordering provider (ECPTPR)^
-        ;ordering provider person class (ECCLASS)^ordering provider npi ECPTNPI
-        N DA,DIK
-        S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1
-        S ECODE=EC7_U_EC23_U_ECINST_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U
-        S ECODE=ECODE_ECSCDT_U_$$RJ^XLFSTR(ECN,4,0)_U_ECRS_U_ECHL_U_ECORDT_U
-        S ECODE=ECODE_$$LJ^XLFSTR(ECORTM,6,0)_U
-        ;convert specialty to PTF Code for transmission
-        N ECXDATA
-        S ECXDATA=$$TSDATA^DGACT(42.4,+ECXTS,.ECXDATA)
-        S ECXTS=$G(ECXDATA(7))
-        ;done
-        S ECODE=ECODE_ECREDT_U_$$LJ^XLFSTR(ECRETM,6,0)_U_ECXMN_U_ECXTS_U_ECWC_U
-        S ECODE1=ECXMPI_U_ECXDSSD_U_ECXDOM_U_ECSCTM_U_ECXOBS_U_ECXENC_U_ECXPDIV_U_ECTRANS
-        I ECXLOGIC>2004 S ECODE1=ECODE1_U_2_ECPTPR_U_ECCLASS
-        I ECXLOGIC>2007 S ECODE1=ECODE1_U_ECPTNPI
-        S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,ECRN=ECRN+1
-        S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA
-        I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1
-        Q
-        ;
-SETUP   ;Set required input for ECXTRAC
-        S ECHEAD="LAR"
-        D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
-        Q
-        ;
-QUE     ; entry point for the background requeuing handled by ECXTAUTO
-        D SETUP,QUE^ECXTAUTO,^ECXKILL Q
+ECXLABR ;ALB/JAP,BIR/CML-LAR Extract for DSS (New Format - With LMIP Codes) ; 4/12/07 8:43am
+ ;;3.0;DSS EXTRACTS;**8,24,33,37,39,46,71,80,107**;Dec 22, 1997;Build 9
+BEG ;entry point from option
+ D SETUP I ECFILE="" Q
+ D ^ECXTRAC,^ECXKILL
+ Q
+ ;
+START ; entry when queued
+ N X,OK,ECTRS,ECTRANS,ECTRIEN,ECDOC,ECDOCPC
+ K ^LAR(64.036) S LRSDT=ECSD,LREDT=ECED
+ D ^LRCAPDAR
+ ;quit if no completion date for API compile
+ I '$P($G(^LAR(64.036,1,2,1,0)),U,4) Q
+ ;build local array of workload codes for local lab tests linked to
+ ;DSS tests
+ K ECLOC S ECDTST=0
+ F  S ECDTST=$O(^ECX(727.2,1,1,ECDTST)) Q:('ECDTST)  S ECLTST=0 D
+ .F  S ECLTST=$O(^ECX(727.2,1,1,ECDTST,"LOC",ECLTST)) Q:'ECLTST  D
+ ..S ECLTIEN=+^ECX(727.2,1,1,ECDTST,"LOC",ECLTST,0)
+ ..S ECWCDA=+$G(^LAB(60,ECLTIEN,64))
+ ..I ECWCDA S ECWC=$P(^LAM(ECWCDA,0),U,2),ECLOC(ECWCDA)=ECWC
+ K ECLTIEN
+ ;process temporary lab file #64.036
+ S QFLG=0,ECLRN=1
+ F  S ECLRN=$O(^LAR(64.036,ECLRN)) Q:('ECLRN)!(QFLG)  D
+ .I $D(^LAR(64.036,ECLRN,0))  D
+ ..S EC1=^LAR(64.036,ECLRN,0),ECF=$P(EC1,U,2)
+ ..Q:ECF=""
+ ..S ECXDFN=$P(EC1,U,3),ECPTPR=$P($G(EC1),U,11),ECCLASS=""
+ ..S ECXTIME=$S($P(EC1,U,10)="":"000300",1:$P(EC1,U,10))
+ ..S ECXDATE=$P(EC1,U,9)_"."_$P(EC1,U,10)
+ ..I ECPTPR S ECCLASS=$$PRVCLASS^ECXUTL(ECPTPR,ECXDATE)
+ ..S ECORDT=$$ECXDATE^ECXUTL($P(EC1,U,4),ECXYM)
+ ..S ECORTM=$$ECXTIME^ECXUTL($P(EC1,U,4)_"."_$P(EC1,U,5))
+ ..S ECREDT=$$ECXDATE^ECXUTL($P(EC1,U,6),ECXYM)
+ ..S ECRETM=$$ECXTIME^ECXUTL($P(EC1,U,6)_"."_$P(EC1,U,7))
+ ..S ECSCDT=$$ECXDATE^ECXUTL($P(EC1,U,9),ECXYM)
+ ..S ECSCTM=$$ECXTIME^ECXUTL($P(EC1,U,9)_"."_$P(EC1,U,10))
+ ..S (ECXADMDT,ECXDOM,ECXDSSD,ECXPNM,ECXSSN,ECXA,ECXMN,ECXTS)=""
+ ..I ECF=2 D  Q:'OK
+ ...K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,ECXDATE,"1;",.ECXPAT)
+ ...Q:'OK
+ ...S ECXPNM=ECXPAT("NAME"),ECXSSN=ECXPAT("SSN"),ECXMPI=ECXPAT("MPI")
+ ...S X=$$INP^ECXUTL2(ECXDFN,ECXDATE),ECXA=$P(X,U),ECXADMDT=$P(X,U,4)
+ ...S ECXMN=$P(X,U,2),ECXTS=$P(X,U,3),ECXDOM=$P(X,U,10)
+ ..;allow for referral patients in future??
+ ..;I ECF=67 S ECSN="000123456",ECNA="RFRL"
+ ..;loop on results multiple
+ ..;
+ ..;Get production division ECXDIEN added p-80
+ ..N ECXPDIV,ECXDIEN S ECXDIEN=$O(^DIC(4,"D",ECINST,"")),ECXPDIV=$$RADDIV^ECXDEPT(ECXDIEN) ;p-46
+ ..K ECXDIEN
+ ..;- Observation patient indicator (y/n)
+ ..S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS)
+ ..;
+ ..;- If no encounter number don't file record
+ ..S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,$P(EC1,U,9),ECXTS,ECXOBS,ECHEAD,,) Q:ECXENC=""
+ ..S ECRES=0
+ ..F  S ECRES=$O(^LAR(64.036,ECLRN,1,ECRES)) Q:('ECRES)!(QFLG)  D
+ ...I $D(^LAR(64.036,ECLRN,1,ECRES,0)) D  Q:QFLG
+ ....S EC2=^LAR(64.036,ECLRN,1,ECRES,0),ECN=$P(EC2,U),ECRS=$P(EC2,U,2)
+ ....S ECHL=$E($P(EC2,U,3)),ECWC=+$P(EC2,U,4)
+ ....S ECWC=$S($D(ECLOC(ECWC)):ECLOC(ECWC),1:"")
+ ....;
+ ....; - Free text results translation
+ ....S ECTRANS="",ECTRS=ECRS
+ ....I +ECTRS S ECTRS=$TR(ECTRS,",","") D
+ .....I (ECTRS?.N)!(ECTRS?.N1".".N) S ECRS=ECTRS
+ ....F  Q:$E(ECTRS,1)'=" "  S ECTRS=$E(ECTRS,2,$L(ECTRS))
+ ....F  Q:$E(ECTRS,$L(ECTRS))'=" "  S ECTRS=$E(ECTRS,1,($L(ECTRS)-1))
+ ....I ECTRS]"" I ECTRS'?.N I ECTRS'?.N1".".N D  ;translate
+ .....S ECTRS=$TR(ECRS,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+ .....S ECTRIEN="",ECTRIEN=$O(^ECX(727.7,"B",ECTRS,ECTRIEN))
+ .....S ECTRANS=$S(ECTRIEN:$P(^ECX(727.7,ECTRIEN,0),U,2),1:5)
+ ....;
+ ....I ECWC]"" D FILE
+ K ^LAR(64.036) S ^LAR(64.036,0)="LAB DSS LAR EXTRACT^64.036^"
+ Q
+ ;
+FILE ;file record
+ ;node0
+ ;facility (ECINST)^dfn (ECXDFN)^ssn (ECXSSN)^name(ECXPNM)^in/out (ECXA)^
+ ;day(ECSCDT)^
+ ;lab test code (ECN)^results (ECRS)^hi/lo indicator (ECHL)^
+ ;date ordered (ECORDT)^time ordered (ECORTM)^date ready (ECREDT)^
+ ;time ready (ECRETM)^
+ ;movement file # (ECXMN)^treating specialty (ECXTS)^
+ ;workload code(ECWC)^
+ ;node1
+ ;mpi (ECXMPI)^dss dept (ECXDSSD)^dom (ECXDOM)^time (ECSCTM)^
+ ;observ pat ind (ECXOBS)^encounter num (ECXENC)^prod div ECXPDIV^
+ ;lab results translation ECXTRANS^ordering provider (ECPTPR)^
+ ;ordering provider person class (ECCLASS)
+ N DA,DIK
+ S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1
+ S ECODE=EC7_U_EC23_U_ECINST_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U
+ S ECODE=ECODE_ECSCDT_U_$$RJ^XLFSTR(ECN,4,0)_U_ECRS_U_ECHL_U_ECORDT_U
+ S ECODE=ECODE_$$LJ^XLFSTR(ECORTM,6,0)_U
+ ;convert specialty to PTF Code for transmission
+ N ECXDATA
+ S ECXDATA=$$TSDATA^DGACT(42.4,+ECXTS,.ECXDATA)
+ S ECXTS=$G(ECXDATA(7))
+ ;done
+ S ECODE=ECODE_ECREDT_U_$$LJ^XLFSTR(ECRETM,6,0)_U_ECXMN_U_ECXTS_U_ECWC_U
+ S ECODE1=ECXMPI_U_ECXDSSD_U_ECXDOM_U_ECSCTM_U_ECXOBS_U_ECXENC_U_ECXPDIV_U_ECTRANS
+ I ECXLOGIC>2004 S ECODE1=ECODE1_U_2_ECPTPR_U_ECCLASS
+ S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,ECRN=ECRN+1
+ S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA
+ I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1
+ Q
+ ;
+SETUP ;Set required input for ECXTRAC
+ S ECHEAD="LAR"
+ D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
+ Q
+ ;
+QUE ; entry point for the background requeuing handled by ECXTAUTO
+ D SETUP,QUE^ECXTAUTO,^ECXKILL Q

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXLBB.m

@@ -1 @@
-ECXLBB  ;DALOI/KML - DSS BLOOD BANK EXTRACT ; 8/12/08 1:00pm
-        ;;3.0;DSS EXTRACTS;**78,84,90,92,104,105,102**;Dec 22, 1997;Build 17
-        ;Per VHA Directive 97-033 this routine should not be modified.  Medical Device # BK970021
-        ; access to the LAB DATA file (#63) is supported by 
-        ; controlled subscription to IA 525  (global root ^LR)  
-        ; access to the BLOOD PRODUCT (#66) is supported by IA 4510
-BEG     ;entry point from option
-        D SETUP I ECFILE="" Q
-        D ^ECXTRAC,^ECXKILL
-        Q
-START   ; Entry point from tasked job
-        ; begin package specific extract
-        N ECTRSP,ECADMT,ECTODT,ECENCTR,ECPAT,ECLRDFN,ECXPHY,ECXPHYPC,ECPHYNPI
-        N ECD,ECXDFN,ECARRY,EC66,ECERR,ECTRFDT,ECTRFTM,ECX,ECINOUT,ECXINST
-        ;variables ECFILE,EC23,ECXYM,ECINST,ECSD,ECSD1,ECED passed in 
-        ; by taskmanager 
-        ; ECED defined in ^ECXTRAC - it represents the end date of the extract
-        ; sort process.  TRANSFUSION DATE should be within start and end dates
-        ; ECED and ECSD were assigned with input provided by the user interface
-        ; and ECSD1 = ECSD-.1
-        ; Read through the TRANSFUSION RECORD sub-file (63.017) of 
-        ; the LAB DATA file (#63)
-        ;the global nodes containing transfusion record entries are constructed
-        ; by calculating the TRANSFUSION DATE/TIME (.01)
-        ; into its reverse date/time representation and then DINUM'd when 
-        ;filing the record entry 
-        ; ECD equals the reverse date/time of ECED+.3 and will need to be
-        ; reset for each DFN.
-        I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 Q  ;quit if tasked and user sends stop request  (QFLG assigned in ECXTRAC)
-AUDRPT  ; entry point for pre-extract audit report
-        S ECTODT=9999999-ECSD1,ECLRDFN=0
-        F  S ECLRDFN=$O(^LR(ECLRDFN)) Q:'ECLRDFN  S ECXDFN=$$GETDFN(ECLRDFN),ECERR=$$PAT(ECXDFN) S ECD=9999999-(ECED+.3) F  S ECD=$O(^LR(ECLRDFN,1.6,ECD)) Q:ECERR  Q:'ECD!(ECD>ECTODT)  S EC0=^LR(ECLRDFN,1.6,ECD,0) D
-        .; ECARRY(1)=TRANSFUSION DATE AND TIME, 
-        .; ECARRY(3)=COMPONENT, ECARRY(4)=COMPONENT ABBREVIATION
-        .; ECARRY(5)=UNITS POOLED, ECARRY(6)=TRANSFUSION REACTION, 
-        .; ECARRY(7)=VOLUME TRANSFUSED, ECARRY(8)=TRANSFUSION REACTION TYPE
-        .; ECARRY(9)=REQUESTING PROVIDER, ECARRY(10)=REQUEST. PROV. PERSON CLASS
-        .; ECARRY(11)=UNIT MODIFIED,ECARRY(12)=UNIT MODIFICATION
-        .; ECARRY(13)=PRODUCTION DIVISION CODE
-        . S ECARRY(1)=$P(EC0,"^"),EC66=$G(^LAB(66,$P(EC0,"^",2),0))
-        . S ECARRY(3)=$E($P(EC66,"^"),1,15),ECARRY(4)=$P(EC66,"^",2)
-        . S ECARRY(5)=$S(+$P(EC0,"^",7)=0:1,1:+$P(EC0,"^",7))
-        . S ECARRY(6)=$S($P(EC0,"^",8)=1:"Y",1:"N"),ECARRY(7)=$P(EC0,"^",10)
-        . S ECARRY(8)=$E($P($G(^LAB(65.4,+$P(EC0,"^",11),0)),"^"),1,10)
-        . S (ECARRY(9),ECARRY(10),ECARRY(13))="" D GETRPRV
-        . S ECARRY(11)=$$MODIFIED(),(ECXPHY,ECXPHYPC,ECPHYNPI)=""
-        . S ECARRY(12)=$S(ECARRY(11)="Y":$$UNITMODS(),1:"")
-        . D GETDATA
-        . K ECARRY
-        D AUDRPT^ECXLBB1
-        Q
-UNITMODS()      ; Get modification criteria from fields #.06 and #3 from file #66
-        N MODARY,MO,EC66A,MODSTR,STR3
-        S MODARY("DIVIDED")="D",MODARY("POOLED")="P",MODARY("WASHED")="W"
-        S MODARY("FROZEN")="F",MODARY("LEUKOCYTE POOR")="L"
-        S MODARY("REJUVENATED")="R",MODARY("DEGLYCEROLIZED")="G"
-        S MODARY("IRRADIATED")="I",MODARY("SEPARATED")="S"
-        ;if modification criteria is null determine value from description
-        S MODSTR=$S($P(EC66,U,6)'="":$P(EC66,U,6),1:$$CHKMOD^ECXLBB1($P(EC66,"^")))
-        ;get modification criteria for entries at field #3 in file #66
-        S MOD=0 F  S MOD=$O(^LAB(66,$P(EC0,"^",2),3,MOD)) Q:'MOD  D
-        .S EC66A=$G(^LAB(66,MOD,0)) I EC66A="" Q
-        .S STR3=$S($P(EC66A,U,6)'="":$P(EC66A,U,6),1:$$CHKMOD^ECXLBB1($P(EC66A,"^")))
-        .I STR3'="",MODSTR'[STR3 S MODSTR=MODSTR_STR3
-        Q MODSTR
-MODIFIED()      ; Was unit modified
-        ; Init variables
-        N XMATCH,UNIT,MOD,COMPID,MODNODE,MODTO
-        S (XMATCH,UNIT)=0,MOD=""
-        ; Check input
-        Q:'$G(ECLRDFN)!'$P(EC0,U,2) "N"
-        ;Find xmatch for blood component request
-        S XMATCH=$O(^LR(ECLRDFN,1.8,$P(EC0,U,2),1,XMATCH)) Q:'XMATCH "N"
-        ;Get blood inventory file (#65) pointer
-        S UNIT=$P($G(^LR(ECLRDFN,1.8,$P(EC0,"^",2),1,XMATCH,0)),U)
-        ;Look at disposition field (#4.1) in blood inventory file (#65)
-        S MOD=$P($G(^LRD(65,+XMATCH,4)),U),COMPID=$P(EC66,U,3)
-        ; Get 'the modified to' entry pointer to blood inventory file (#66)
-        I MOD="MO" S MODTO=0 F  S MODTO=$O(^LRD(65,+XMATCH,9,MODTO)) Q:'MODTO  D
-        .S MODNODE=$G(^LRD(65,+XMATCH,9,MODTO,0)) Q:$P(^(0),U,3)'>1
-        .Q:$P(MODNODE,U,2)'=COMPID
-        .; Set the modify to unit ien for file (#66)
-        Q $S(MOD="MO":"Y",1:"N")
-GETRPRV ; get requesting provider, requesting provider person class and 
-        ; production division code
-        ; input: ECD      =INVERTED DATE SUBSCRIPT
-        ;        ECARRY(1)=TRANSFUSION DATE AND TIME
-        ; note: Accessioned data in file #68 is stored up to 90 days.
-        N ECXBNOD,ACC,ACCDT,ACCNODE,PERCLS
-        I ECARRY(1)="" Q  ;there is no transfusion date
-        ;get BLOOD BANK record, field #1, in file #63 located on "BB" node
-        ;since there is a slight time lapse, $O will find the BB record
-        S ECXBNOD=$O(^LR(ECLRDFN,"BB",ECD)) I ECXBNOD="" Q
-        S ECXBNOD=^LR(ECLRDFN,"BB",ECXBNOD,0) I ECXBNOD="" Q
-        ;Compose accession number,originating from field #.06 subfile #63.01
-        ; ex. ACC=BB 0528 27
-        S ACC=$P(ECXBNOD,U,6),ACC=$TR($P(ACC," ",2,99)," ")
-        S ACCDT=$E(ECARRY(1),1,3)_$E(ACC,1,4),NUM=$E(ACC,5,99)
-        ;Get field #2 from file #68, field #1 from subfile #68.01 which is
-        ;subfile #68.02. Look at 29=blood bank ien, from 0th node, get fields
-        ;#6.5 PROVIDER and #26 DIV
-        I (ACCDT)=""!(NUM="") Q
-        ; identify bb accession area the patient was in to get the right DIV
-        S AREA=$$AREA
-        S ACCNODE=$G(^LRO(68,+AREA,1,ACCDT,1,NUM,0))
-        S ECARRY(9)=$P(ACCNODE,U,8) I ECARRY(9)'="" D
-        . S PERCLS=$$GET^XUA4A72(ECARRY(9),ACCDT)
-        . I +PERCLS>0 S ECARRY(10)=$P(PERCLS,U,7)
-        . S ECREQNPI=$$NPI^XUSNPI("Individual_ID",ECARRY(9),ACCDT)
-        . S:+ECREQNPI'>0 ECREQNPI="" S ECREQNPI=$P(ECREQNPI,U)
-        . S ECARRY(9)=2_ECARRY(9)
-        S DIV=$P($G(^LRO(68,+AREA,1,ACCDT,1,NUM,.4)),U)
-        I DIV'="" S ECARRY(13)=$$RADDIV^ECXDEPT(DIV)
-        Q
-AREA()  ; resolve accession area's ien to use and validate
-        ;          Accession number
-        ;          Patient LRDFN
-        ; note: if there is only one accession area use '29'
-        N A,CNT,BBLIST,DFN,ACC,AREA,DATE,TDATE,ACCNODE
-        S (CNT,FLAG,A)=0,DFN=""
-        ; set the date from the "bb" node in file (#63)
-        S DATE=$P(ECXBNOD,U)
-        ; setup array for bb accession areas if more than one
-        F  S A=$O(^LRO(68,A)) Q:'A  I $P($G(^LRO(68,A,0)),"^",2)="BB" D
-        . S BBLIST(A)=""
-        . S CNT=CNT+1
-        I CNT'>1 Q 29
-        S AREA=0 F  S AREA=$O(BBLIST(AREA)) Q:'AREA  D  Q:FLAG
-        . ; get additional accession information for validation
-        . S ACCNODE=$G(^LRO(68,AREA,1,$P(DATE,"."),1,NUM,0))
-        . S ACC=$G(^LRO(68,AREA,1,$P(DATE,"."),1,NUM,.2))
-        . S DFN=$P($G(ACCNODE),U)
-        . S TDATE=$P($G(^LRO(68,AREA,1,$P(DATE,"."),1,NUM,3)),U)
-        . I (DFN=ECLRDFN)&(ACC=$P(ECXBNOD,U,6))&(DATE=TDATE) S FLAG=1
-        Q AREA
-GETDATA ; gather rest of extract data that will be recorded in an 
-        ; entry in file 727.829
-        S ECTRFDT=$$ECXDOB^ECXUTL(ECARRY(1)),ECTRFTM=$$ECXTIME^ECXUTL(ECARRY(1))
-        S ECX=$$INP^ECXUTL2(ECXDFN,ECARRY(1)),ECINOUT=$P(ECX,U),ECTRSP=$P(ECX,U,3),ECADMT=$P(ECX,U,4) ; [FLD #5]
-        ;
-        ;- Observation patient indicator (YES/NO)
-        S ECXOBS=$$OBSPAT^ECXUTL4(ECINOUT,ECTRSP)
-        ;- If no encounter number don't file record
-        S ECENCTR=$$ENCNUM^ECXUTL4(ECINOUT,ECPAT("SSN"),ECADMT,ECARRY(1),ECTRSP,ECXOBS,ECHEAD,,) ; [FLD #6]
-        Q:ECENCTR=""
-        ;get emergency response indicator (FEMA)
-        S ECXERI=ECPAT("ERI")
-        ;
-        S ECXSTR=$G(EC23)_"^"_ECINST_"^"_ECXDFN_"^"_ECPAT("SSN")_"^"_ECPAT("NAME")_"^"_ECINOUT_"^"_ECENCTR_"^"_ECTRFDT_"^"_ECTRFTM_"^"_ECARRY(3)_"^"_ECARRY(4)_"^"_ECARRY(5)_"^"_ECARRY(7)_"^"_ECARRY(6)_"^"_ECARRY(8)_"^BB"_ECARRY(13)_"^^"
-        I $G(ECXLOGIC)>2005 S ECXSTR=ECXSTR_U_ECXPHY_U_ECXPHYPC
-        I $G(ECXLOGIC)>2006 D
-        .S ECXSTR=ECXSTR_U_ECXERI_U_ECARRY(11)_U_ECARRY(12)_U_ECARRY(9)_U_ECARRY(10)_U_ECARRY(13)_U
-        I '$D(ECXRPT) D FILE(ECXSTR) Q
-        S ^TMP("ECXLBB",$J,ECXDFN,ECD)=ECXSTR  ;temporary global array
-        ;   used in ECXPLBB (pre-extract audit report)
-        Q
-GETDFN(ECXLRDFN)        ;
-        ; INPUT - LRDFN
-        ; OUTPUT - DFN
-        ; Obtains DFN (Patient ID) from LRDFN (Lab Patient ID).
-        ; If no valid DFN exists, 0 is returned.
-        S ECXLRDFN=+$G(ECXLRDFN)
-        I $P($G(^LR(ECXLRDFN,0)),"^",2)'=2 Q 0
-        Q +$P(^LR(ECXLRDFN,0),"^",3)
-        ; 
-PAT(ECXDFN)     ;get/set patient data
-        ; INPUT - ECXDFN = patient ien (DFN)
-        ; OUTPUT - ECPAT array:
-        ;          ECPAT("SSN")
-        ;          ECPAT("NAME")
-        ; returns 0 or 1 in ECXERR - 0=successful
-        ;                            1=error condition
-        N X,OK,ECXERR
-        ;get data
-        S ECXERR=0
-        K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,"","1;3",.ECPAT)
-        I 'OK S ECXERR=1
-        Q ECXERR
-        ;
-FILE(ECODE)     ;
-        ; Input - ECODE = extract record
-        ;
-        ; record the extract record at a global node in file 727.829
-        ; sequence #^year/month of extract^extract #^facility^patient dfn^SSN^
-        ; name^i/o pt indicator^encounter #^date of transfusion^time of 
-        ; transfusion^component^component abbrev^# of units^volume in mm^
-        ; reaction^reaction type^feeder location^DSS product dept^DSS IP #
-        ; ordering physician^ordering physician pc^emergency response indicator
-        ; (FEMA)^unit modified^unit modification^requesting provider^request. 
-        ; provider person class^ordering provider npi ECPHYNPI
-        ;ECODE1- requesting provider npi ECREQNPI
-        ;note:  DSS product dept and DSS IP # are dependent on the release of
-        ; ECX*3*61
-        N DA,DIK,EC7
-        S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1
-        S ECODE=EC7_"^"_ECODE
-        I ECXLOGIC>2007 D
-        .S ECODE=ECODE_ECPHYNPI_U
-        .S ECODE1=$G(ECREQNPI)
-        S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=$G(ECODE1),ECRN=ECRN+1
-        S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA
-        Q
-        ;
-        ;
-SETUP   ;Set required input for ECXTRAC.
-        S ECHEAD="LBB"
-        D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
-        Q
-        ;
-LOCAL   ; to extract nightly for local use not to be transmitted to TSI
-        ; should be queued with a 1D frequency
-        D SETUP,^ECXTLOCL,^ECXKILL Q
-        ;
-QUE     ; entry point for the background requeuing handled by ECXTAUTO
-        D SETUP,QUE^ECXTAUTO,^ECXKILL
-        Q
-        ;
-        ;ECXLBB
+ECXLBB ;DALOI/KML - DSS BLOOD BANK EXTRACT ; 2/22/07 11:42am
+ ;;3.0;DSS EXTRACTS;**78,84,90,92,104**;Dec 22, 1997;Build 8
+ ;Per VHA Directive 97-033 this routine should not be modified.  Medical Device # BK970021
+ ; access to the LAB DATA file (#63) is supported by 
+ ; controlled subscription to IA 525  (global root ^LR)  
+ ; access to the BLOOD PRODUCT (#66) is supported by IA 4510
+BEG ;entry point from option
+ D SETUP I ECFILE="" Q
+ D ^ECXTRAC,^ECXKILL
+ Q
+ ;
+START ; Entry point from tasked job
+ ; begin package specific extract
+ N ECTRSP,ECADMT,ECTODT,ECENCTR,ECPAT,ECLRDFN,ECXPHY,ECXPHYPC
+ N ECD,ECXDFN,ECARRY,EC66,ECERR,ECTRFDT,ECTRFTM,ECX,ECINOUT,ECXINST
+ ;variables ECFILE,EC23,ECXYM,ECINST,ECSD,ECSD1,ECED passed in 
+ ; by taskmanager 
+ ; ECED defined in ^ECXTRAC - it represents the end date of the extract
+ ; sort process.  TRANSFUSION DATE should be within start and end dates
+ ; ECED and ECSD were assigned with input provided by the user interface
+ ; and ECSD1 = ECSD-.1
+ ; Read through the TRANSFUSION RECORD sub-file (63.017) of 
+ ; the LAB DATA file (#63)
+ ;the global nodes containing transfusion record entries are constructed
+ ; by calculating the TRANSFUSION DATE/TIME (.01)
+ ; into its reverse date/time representation and then DINUM'd when 
+ ;filing the record entry 
+ ; ECD equals the reverse date/time of ECED+.3 and will need to be
+ ; reset for each DFN.
+ I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 Q  ;quit if tasked and user sends stop request  (QFLG assigned in ECXTRAC)
+AUDRPT ; entry point for pre-extract audit report
+ S ECTODT=9999999-ECSD1,ECLRDFN=0
+ F  S ECLRDFN=$O(^LR(ECLRDFN)) Q:'ECLRDFN  S ECXDFN=$$GETDFN(ECLRDFN),ECERR=$$PAT(ECXDFN) S ECD=9999999-(ECED+.3) F  S ECD=$O(^LR(ECLRDFN,1.6,ECD)) Q:ECERR  Q:'ECD!(ECD>ECTODT)  S EC0=^LR(ECLRDFN,1.6,ECD,0) D
+ .; ECARRY(1)=TRANSFUSION DATE AND TIME, 
+ .; ECARRY(3)=COMPONENT, ECARRY(4)=COMPONENT ABBREVIATION
+ .; ECARRY(5)=UNITS POOLED, ECARRY(6)=TRANSFUSION REACTION, 
+ .; ECARRY(7)=VOLUME TRANSFUSED, ECARRY(8)=TRANSFUSION REACTION TYPE
+ .; ECARRY(9)=REQUESTING PROVIDER, ECARRY(10)=REQUEST. PROV. PERSON CLASS
+ .; ECARRY(11)=UNIT MODIFIED, ECARRY(12)=UNIT MODIFICATION
+ .; ECARRY(13)=PRODUCTION DIVISION CODE
+ . S ECARRY(1)=$P(EC0,"^"),EC66=$G(^LAB(66,$P(EC0,"^",2),0))
+ . S ECARRY(3)=$E($P(EC66,"^"),1,15),ECARRY(4)=$P(EC66,"^",2)
+ . S ECARRY(5)=$S(+$P(EC0,"^",7)=0:1,1:+$P(EC0,"^",7))
+ . S ECARRY(6)=$S($P(EC0,"^",8)=1:"Y",1:"N"),ECARRY(7)=$P(EC0,"^",10)
+ . S ECARRY(8)=$E($P($G(^LAB(65.4,+$P(EC0,"^",11),0)),"^"),1,10)
+ . S (ECARRY(9),ECARRY(10),ECARRY(13))="" D GETRPRV
+ . S ECARRY(12)=$$UNITMOD(),ECARRY(11)=$S(ECARRY(12)'="":"Y",1:"N")
+ . S (ECXPHY,ECXPHYPC)=""
+ . D GETDATA
+ . K ECARRY
+ Q
+ ;
+UNITMOD() ; Get modification criteria from fields #.06 and #3 from file #66
+ N MODARY,MO,EC66A,MODSTR,STR3
+ S MODARY("DIVIDED")="D",MODARY("POOLED")="P",MODARY("WASHED")="W"
+ S MODARY("FROZEN")="F",MODARY("LEUKOCYTE POOR")="L"
+ S MODARY("REJUVENATED")="R",MODARY("DEGLYCEROLIZED")="G"
+ S MODARY("IRRADIATED")="I",MODARY("SEPARATED")="S"
+ ;if modification criteria is null determine value from description
+ S MODSTR=$S($P(EC66,U,6)'="":$P(EC66,U,6),1:$$CHKMOD($P(EC66,"^")))
+ ;get modification criteria for entries at field #3 in file #66
+ S MOD=0 F  S MOD=$O(^LAB(66,$P(EC0,"^",2),3,MOD)) Q:'MOD  D
+ .S EC66A=$G(^LAB(66,MOD,0)) I EC66A="" Q
+ .S STR3=$S($P(EC66A,U,6)'="":$P(EC66A,U,6),1:$$CHKMOD($P(EC66A,"^")))
+ .I STR3'="",MODSTR'[STR3 S MODSTR=MODSTR_STR3
+ Q MODSTR
+ ;
+CHKMOD(MD) ;check if modifier is contained in string
+ N RES,MODX
+ I MD="" Q ""
+ S (RES,MODX)="" F  S MODX=$O(MODARY(MODX)) Q:MODX=""  D  I RES'="" Q
+ .I MD[MODX S RES=MODARY(MODX)
+ Q RES
+GETRPRV ; get requesting provider, requesting provider person class and 
+ ; production division code
+ ; input: ECD      =INVERTED DATE SUBSCRIPT
+ ;        ECARRY(1)=TRANSFUSION DATE AND TIME
+ ; note: Accessioned data in file #68 is stored up to 90 days.
+ N ECXBNOD,ACC,ACCDT,ACCNODE,PERCLS
+ I ECARRY(1)="" Q  ;there is no transfusion date
+ ;get BLOOD BANK record, field #1, in file #63 located on "BB" node
+ ;since there is a slight time lapse, $O will find the BB record
+ S ECXBNOD=$O(^LR(ECLRDFN,"BB",ECD)) I ECXBNOD="" Q
+ S ECXBNOD=^LR(ECLRDFN,"BB",ECXBNOD,0) I ECXBNOD="" Q
+ ;Compose accession number,originating from field #.06 subfile #63.01
+ ; ex. ACC=BB 0528 27
+ S ACC=$P(ECXBNOD,U,6),ACC=$TR($P(ACC," ",2,99)," ")
+ S ACCDT=$E(ECARRY(1),1,3)_$E(ACC,1,4),NUM=$E(ACC,5,99)
+ ;Get field #2 from file #68, field #1 from subfile #68.01 which is
+ ;subfile #68.02. Look at 29=blood bank ien, from 0th node, get fields
+ ;#6.5 PROVIDER and #26 DIV
+ I (ACCDT)=""!(NUM="") Q
+ ; identify bb accession area the patient was in to get the right DIV
+ S AREA=$$AREA
+ S ACCNODE=$G(^LRO(68,+AREA,1,ACCDT,1,NUM,0))
+ S ECARRY(9)=$P(ACCNODE,U,8) I ECARRY(9)'="" D
+ . S PERCLS=$$GET^XUA4A72(ECARRY(9),ACCDT)
+ . I +PERCLS>0 S ECARRY(10)=$P(PERCLS,U,7)
+ . S ECARRY(9)=2_ECARRY(9)
+ S DIV=$P($G(^LRO(68,+AREA,1,ACCDT,1,NUM,.4)),U)
+ I DIV'="" S ECARRY(13)=$$RADDIV^ECXDEPT(DIV)
+ Q
+ ;
+AREA() ; resolve accession area's ien to use and validate
+ ;          Accession number
+ ;          Patient LRDFN
+ ; note: if there is only one accession area use '29'
+ N A,CNT,BBLIST,DFN,ACC,AREA,DATE,TDATE,ACCNODE
+ S (CNT,FLAG,A)=0,DFN=""
+ ; set the date from the "bb" node in file (#63)
+ S DATE=$P(ECXBNOD,U)
+ ; setup array for bb accession areas if more than one
+ F  S A=$O(^LRO(68,A)) Q:'A  I $P($G(^LRO(68,A,0)),"^",2)="BB" D
+ . S BBLIST(A)=""
+ . S CNT=CNT+1
+ I CNT'>1 Q 29
+ S AREA=0 F  S AREA=$O(BBLIST(AREA)) Q:'AREA  D  Q:FLAG
+ . ; get additional accession information for validation
+ . S ACCNODE=$G(^LRO(68,AREA,1,$P(DATE,"."),1,NUM,0))
+ . S ACC=$G(^LRO(68,AREA,1,$P(DATE,"."),1,NUM,.2))
+ . S DFN=$P($G(ACCNODE),U)
+ . S TDATE=$P($G(^LRO(68,AREA,1,$P(DATE,"."),1,NUM,3)),U)
+ . I (DFN=ECLRDFN)&(ACC=$P(ECXBNOD,U,6))&(DATE=TDATE) S FLAG=1
+ Q AREA
+ ;
+GETDATA ; gather rest of extract data that will be recorded in an 
+ ; entry in file 727.829
+ S ECTRFDT=$$ECXDOB^ECXUTL(ECARRY(1)),ECTRFTM=$$ECXTIME^ECXUTL(ECARRY(1))
+ S ECX=$$INP^ECXUTL2(ECXDFN,ECARRY(1)),ECINOUT=$P(ECX,U),ECTRSP=$P(ECX,U,3),ECADMT=$P(ECX,U,4) ; [FLD #5]
+ ;
+ ;- Observation patient indicator (YES/NO)
+ S ECXOBS=$$OBSPAT^ECXUTL4(ECINOUT,ECTRSP)
+ ;- If no encounter number don't file record
+ S ECENCTR=$$ENCNUM^ECXUTL4(ECINOUT,ECPAT("SSN"),ECADMT,ECARRY(1),ECTRSP,ECXOBS,ECHEAD,,) ; [FLD #6]
+ Q:ECENCTR=""
+ ;get emergency response indicator (FEMA)
+ S ECXERI=ECPAT("ERI")
+ ;
+ S ECXSTR=$G(EC23)_"^"_ECINST_"^"_ECXDFN_"^"_ECPAT("SSN")_"^"_ECPAT("NAME")_"^"_ECINOUT_"^"_ECENCTR_"^"_ECTRFDT_"^"_ECTRFTM_"^"_ECARRY(3)_"^"_ECARRY(4)_"^"_ECARRY(5)_"^"_ECARRY(7)_"^"_ECARRY(6)_"^"_ECARRY(8)_"^BB"_ECARRY(13)_"^^"
+ I $G(ECXLOGIC)>2005 S ECXSTR=ECXSTR_U_ECXPHY_U_ECXPHYPC
+ I $G(ECXLOGIC)>2006 D
+ .S ECXSTR=ECXSTR_U_ECXERI_U_ECARRY(11)_U_ECARRY(12)_U_ECARRY(9)_U_ECARRY(10)_U_ECARRY(13)
+ I '$D(ECXRPT) D FILE(ECXSTR) Q
+ S ^TMP("ECXLBB",$J,ECXDFN,ECD)=ECXSTR  ;temporary global array
+ ;   used in ECXPLBB (pre-extract audit report)
+ Q
+ ;
+GETDFN(ECXLRDFN) ;
+ ; INPUT - LRDFN
+ ; OUTPUT - DFN
+ ; Obtains DFN (Patient ID) from LRDFN (Lab Patient ID).
+ ; If no valid DFN exists, 0 is returned.
+ S ECXLRDFN=+$G(ECXLRDFN)
+ I $P($G(^LR(ECXLRDFN,0)),"^",2)'=2 Q 0
+ Q +$P(^LR(ECXLRDFN,0),"^",3)
+ ; 
+PAT(ECXDFN) ;get/set patient data
+ ; INPUT - ECXDFN = patient ien (DFN)
+ ; OUTPUT - ECPAT array:
+ ;          ECPAT("SSN")
+ ;          ECPAT("NAME")
+ ; returns 0 or 1 in ECXERR - 0=successful
+ ;                            1=error condition
+ N X,OK,ECXERR
+ ;get data
+ S ECXERR=0
+ K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,"","1;3",.ECPAT)
+ I 'OK S ECXERR=1
+ Q ECXERR
+ ;
+FILE(ECODE) ;
+ ; Input - ECODE = extract record
+ ;
+ ; record the extract record at a global node in file 727.829
+ ; sequence #^year/month of extract^extract #^facility^patient dfn^SSN^
+ ; name^i/o pt indicator^encounter #^date of transfusion^time of 
+ ; transfusion^component^component abbrev^# of units^volume in mm^
+ ; reaction^reaction type^feeder location^DSS product dept^DSS IP #
+ ; ordering physician^ordering physician pc^emergency response indicator
+ ; (FEMA)^unit modified^unit modification^requesting provider^request. 
+ ; provider person class
+ ;note:  DSS product dept and DSS IP # are dependent on the release of
+ ; ECX*3*61
+ N DA,DIK,EC7
+ S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1
+ S ECODE=EC7_"^"_ECODE
+ S ^ECX(ECFILE,EC7,0)=ECODE,ECRN=ECRN+1
+ S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA
+ Q
+ ;
+ ;
+SETUP ;Set required input for ECXTRAC.
+ S ECHEAD="LBB"
+ D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
+ Q
+ ;
+LOCAL ; to extract nightly for local use not to be transmitted to TSI
+ ; should be queued with a 1D frequency
+ D SETUP,^ECXTLOCL,^ECXKILL Q
+ ;
+QUE ; entry point for the background requeuing handled by ECXTAUTO
+ D SETUP,QUE^ECXTAUTO,^ECXKILL
+ Q
+ ;
+ ;ECXLBB

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXMOV.m

@@ -1 @@
-ECXMOV  ;ALB/JAP,BIR/DMA,PTD-Transfer and Discharge Extract ; 6/6/07 6:46am
-        ;;3.0;DSS EXTRACTS;**8,24,33,39,41,42,46,65,84,107,105**;Dec 22, 1997;Build 70
-BEG     ;entry point from option
-        D SETUP I ECFILE="" Q
-        D ^ECXTRAC,^ECXKILL
-        Q
-        ;
-START   ; start package specific extract
-        N ECXDSC,W,WTO,X1,X2,X,ECXDPRPC,ECXDAPPC
-        K ECXDD D FIELD^DID(405,.19,,"SPECIFIER","ECXDD")
-        S ECPRO=$E(+$P(ECXDD("SPECIFIER"),"P",2)) K ECXDD
-        S ECED=ECED+.3,QFLG=0
-        F ECM=2,3 S ECARG="ATT"_ECM,ECD=ECSD1 D  Q:QFLG
-        .F  S ECD=$O(^DGPM(ECARG,ECD)),ECDA=0 Q:('ECD)!(ECD>ECED)  D  Q:QFLG
-        ..F  S ECDA=$O(^DGPM(ECARG,ECD,ECDA)) Q:'ECDA  D  Q:QFLG
-        ...Q:'$D(^DGPM(ECDA,0))  S EC=^(0)
-        ...S ECXDFN=+$P(EC,U,3),ECMT=$P(EC,U,18),ECXDATE=ECD
-        ...K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECXDATE,"."),"1;",.ECXPAT)
-        ...I 'OK K ECXPAT Q
-        ...S ECXPNM=ECXPAT("NAME"),ECXSSN=ECXPAT("SSN"),ECXMPI=ECXPAT("MPI")
-        ...S ECTM=$$ECXTIME^ECXUTL(ECD)
-        ...S WTO=$P(EC,U,6),ECXWTO=$P($G(^DIC(42,+WTO,44)),U)
-        ...;
-        ...;reset EC to admission movement
-        ...S ECCA=$P(EC,U,14),EC=^DGPM(ECCA,0),ECA=$P(EC,U)
-        ...;
-        ...;if date of previous xfer movement is greater than admit date,
-        ...;then reset EC to that previous xfer movement
-        ...S ECDL=9999999.9999999-ECD,ECDL=+$O(^DGPM("ATID2",ECXDFN,ECDL))
-        ...S ECDAL=+$O(^DGPM("ATID2",ECXDFN,ECDL,0))
-        ...I $D(^DGPM(ECDAL,0)),$P(^(0),U)>$P(EC,U) S EC=^(0)
-        ...;
-        ...I ECM=2 D
-        ....;if transact=Transfer,ECD (time)=ASIH (7chars) and >0,set ECXDATE
-        ....;to Admit DT/time before calling funct to get in/out stat & TS
-        ....I $L($P(ECD,".",2))=7,+$E($P(ECD,".",2),7)>0 S ECXDATE=ECA
-        ....S W=$P(EC,U,6)
-        ...;
-        ...I ECM=3 D
-        ....;subtract 1 second from dischg DT so IN5^VADPT call (in ECXUTL2
-        ....;API) will pick up discharge movmement record
-        ....S ECXDATE=$$FMADD^XLFDT(ECXDATE,,,,-1)
-        ....;set losing ward to ward at discharge
-        ....N WARD S WARD=$$GET1^DIQ(405,ECDA,200)
-        ....I WARD'="" S W=+$O(^DIC(42,"B",WARD,0))
-        ...;
-        ...;-Gets inpat/outpat status, DOM, Treating Spec (TS)
-        ...S X=$$INP^ECXUTL2(ECXDFN,ECXDATE),ECXA=$P(X,U),ECXDOM=$P(X,U,10),ECXTS=$P(X,U,3)
-        ...;
-        ...S (ECXWRD,ECXFAC,ECXDSSD)=""
-        ...I W'="" D
-        ....S ECXWRD=$P($G(^DIC(42,W,44)),U),ECXFAC=$P($G(^DIC(42,W,0)),U,11)
-        ....S ECXDSSD=$P($G(^ECX(727.4,W,0)),U,2)
-        ...S ECDI=$S(ECM=2:"",1:$$ECXDATE^ECXUTL(ECD,ECXYM))
-        ...S X1=ECD,X2=$P(EC,U) D ^%DTC S ECXLOS=X
-        ...;
-        ...;- Get discharge PC Team, Primary and Assoc Primary Provider
-        ...S (ECXDPCT,ECXDPR,ECXDAPR,ECXDPRPC,ECXDAPPC)=""
-        ...I ECM=3 D
-        ....S ECXDSC=$$PRIMARY^ECXUTL2(ECXDFN,ECD)
-        ....S ECXDPCT=$P(ECXDSC,U),ECXDPR=$P(ECXDSC,U,2),ECXDAPR=$P(ECXDSC,U,5),ECXDPRPC=$P(ECXDSC,U,3),ECXDAPPC=$P(ECXDSC,U,6)
-        ....S ECDAPRNP=$P(ECXDSC,U,7),ECDPRNPI=$P(ECXDSC,U,4)
-        ...;
-        ...;Get production division ;p-46
-        ...N ECXPDIV S ECXPDIV=$$GETDIV^ECXDEPT(ECXFAC) ;p-46 
-        ...;- Observation patient indicator (YES/NO)
-        ...S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS)
-        ...;
-        ...;- If no encounter number, don't file record
-        ...S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECA,,ECXTS,ECXOBS,ECHEAD,,)
-        ...D:ECXENC'="" FILE
-        Q
-        ;
-FILE    ;file the extract record
-        ;node0
-        ;fac ECXFAC^dfn ECXDFN^ssn ECXSSN^name ECXPNM^in/out ECXA^
-        ;day (ECD)^^adm date (ECA)^disc date ECDI^mov # ECDA^
-        ;type ECM^losing ward ECXWARD^treat spec ^los ECXLOS^^
-        ;movement type ECMT^mov time ECTM^gaining ward ECXWTO^
-        ;adm time (ECA)^^^
-        ;node1
-        ;mpi ECXMPI^dss dept ECXDSSD^dom ECXDOM^observ pat ind ECXOBS^
-        ;encounter num ECXENC^disch prim prov ECXDPR^disch PC team ECXDPCT^
-        ;disch assoc prim prov ECXDAPR^production division ECXPDIV
-        ;^disch prov person class ECXDPRPC^disch assoc prov pe-
-        ;rson person class^disch assoc pc prov npi ECDAPRNP^discharge pc provider npi ECDPRNPI
-        N DA,DIK
-        S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1
-        S ECODE=EC7_U_EC23_U_ECXFAC_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U
-        S ECODE=ECODE_$$ECXDATE^ECXUTL(ECD,ECXYM)_U_U
-        S ECODE=ECODE_$$ECXDATE^ECXUTL(ECA,ECXYM)_U_ECDI_U_ECDA_U_ECM_U_ECXWRD_U
-        S ECODE=ECODE_U_ECXLOS_U_U_ECMT_U_ECTM_U_ECXWTO_U
-        S ECODE=ECODE_$$ECXTIME^ECXUTL(ECA)_U_U_U
-        S ECODE1=ECXMPI_U_ECXDSSD_U_ECXDOM_U_ECXOBS_U_ECXENC_U_ECXDPR_U
-        S ECODE1=ECODE1_ECXDPCT_U_ECXDAPR_U_ECXPDIV ;p-46 added ECXPDIV
-        I ECXLOGIC>2005 S ECODE1=ECODE1_U_ECXDPRPC_U_ECXDAPPC
-        I ECXLOGIC>2007 S ECODE1=ECODE1_U_$G(ECDAPRNP)_U_$G(ECDPRNPI)
-        S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,ECRN=ECRN+1
-        S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA
-        I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1
-        Q
-        ;
-SETUP   ;Set required input for ECXTRAC
-        S ECHEAD="MOV"
-        D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
-        Q
-        ;
-QUE     ; entry point for the background requeuing handled by ECXTAUTO
-        D SETUP,QUE^ECXTAUTO,^ECXKILL Q
+ECXMOV ;ALB/JAP,BIR/DMA,PTD-Transfer and Discharge Extract ; 8/19/05 9:13am
+ ;;3.0;DSS EXTRACTS;**8,24,33,39,41,42,46,65,84**;Dec 22, 1997
+BEG ;entry point from option
+ D SETUP I ECFILE="" Q
+ D ^ECXTRAC,^ECXKILL
+ Q
+ ;
+START ; start package specific extract
+ N ECXDSC,W,WTO,X1,X2,X,ECXDPRPC,ECXDAPPC
+ K ECXDD D FIELD^DID(405,.19,,"SPECIFIER","ECXDD")
+ S ECPRO=$E(+$P(ECXDD("SPECIFIER"),"P",2)) K ECXDD
+ S ECED=ECED+.3,QFLG=0
+ F ECM=2,3 S ECARG="ATT"_ECM,ECD=ECSD1 D  Q:QFLG
+ .F  S ECD=$O(^DGPM(ECARG,ECD)),ECDA=0 Q:('ECD)!(ECD>ECED)  D  Q:QFLG
+ ..F  S ECDA=$O(^DGPM(ECARG,ECD,ECDA)) Q:'ECDA  D  Q:QFLG
+ ...Q:'$D(^DGPM(ECDA,0))  S EC=^(0)
+ ...S ECXDFN=+$P(EC,U,3),ECMT=$P(EC,U,18),ECXDATE=ECD
+ ...K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECXDATE,"."),"1;",.ECXPAT)
+ ...I 'OK K ECXPAT Q
+ ...S ECXPNM=ECXPAT("NAME"),ECXSSN=ECXPAT("SSN"),ECXMPI=ECXPAT("MPI")
+ ...S ECTM=$$ECXTIME^ECXUTL(ECD)
+ ...S WTO=$P(EC,U,6),ECXWTO=$P($G(^DIC(42,+WTO,44)),U)
+ ...;
+ ...;reset EC to admission movement
+ ...S ECCA=$P(EC,U,14),EC=^DGPM(ECCA,0),ECA=$P(EC,U)
+ ...;
+ ...;if date of previous xfer movement is greater than admit date,
+ ...;then reset EC to that previous xfer movement
+ ...S ECDL=9999999.9999999-ECD,ECDL=+$O(^DGPM("ATID2",ECXDFN,ECDL))
+ ...S ECDAL=+$O(^DGPM("ATID2",ECXDFN,ECDL,0))
+ ...I $D(^DGPM(ECDAL,0)),$P(^(0),U)>$P(EC,U) S EC=^(0)
+ ...;
+ ...I ECM=2 D
+ ....;if transact=Transfer,ECD (time)=ASIH (7chars) and >0,set ECXDATE
+ ....;to Admit DT/time before calling funct to get in/out stat & TS
+ ....I $L($P(ECD,".",2))=7,+$E($P(ECD,".",2),7)>0 S ECXDATE=ECA
+ ....S W=$P(EC,U,6)
+ ...;
+ ...I ECM=3 D
+ ....;subtract 1 second from dischg DT so IN5^VADPT call (in ECXUTL2
+ ....;API) will pick up discharge movmement record
+ ....S ECXDATE=$$FMADD^XLFDT(ECXDATE,,,,-1)
+ ....;set losing ward to ward at discharge
+ ....N WARD S WARD=$$GET1^DIQ(405,ECDA,200)
+ ....I WARD'="" S W=+$O(^DIC(42,"B",WARD,0))
+ ...;
+ ...;-Gets inpat/outpat status, DOM, Treating Spec (TS)
+ ...S X=$$INP^ECXUTL2(ECXDFN,ECXDATE),ECXA=$P(X,U),ECXDOM=$P(X,U,10),ECXTS=$P(X,U,3)
+ ...;
+ ...S (ECXWRD,ECXFAC,ECXDSSD)=""
+ ...I W'="" D
+ ....S ECXWRD=$P($G(^DIC(42,W,44)),U),ECXFAC=$P($G(^DIC(42,W,0)),U,11)
+ ....S ECXDSSD=$P($G(^ECX(727.4,W,0)),U,2)
+ ...S ECDI=$S(ECM=2:"",1:$$ECXDATE^ECXUTL(ECD,ECXYM))
+ ...S X1=ECD,X2=$P(EC,U) D ^%DTC S ECXLOS=X
+ ...;
+ ...;- Get discharge PC Team, Primary and Assoc Primary Provider
+ ...S (ECXDPCT,ECXDPR,ECXDAPR,ECXDPRPC,ECXDAPPC)=""
+ ...I ECM=3 D
+ ....S ECXDSC=$$PRIMARY^ECXUTL2(ECXDFN,ECD)
+ ....S ECXDPCT=$P(ECXDSC,U),ECXDPR=$P(ECXDSC,U,2),ECXDAPR=$P(ECXDSC,U,5),ECXDPRPC=$P(ECXDSC,U,3),ECXDAPPC=$P(ECXDSC,U,6)
+ ...;
+ ...;Get production division ;p-46
+ ...N ECXPDIV S ECXPDIV=$$GETDIV^ECXDEPT(ECXFAC) ;p-46 
+ ...;- Observation patient indicator (YES/NO)
+ ...S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS)
+ ...;
+ ...;- If no encounter number, don't file record
+ ...S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECA,,ECXTS,ECXOBS,ECHEAD,,)
+ ...D:ECXENC'="" FILE
+ Q
+ ;
+FILE ;file the extract record
+ ;node0
+ ;fac ECXFAC^dfn ECXDFN^ssn ECXSSN^name ECXPNM^in/out ECXA^
+ ;day (ECD)^^adm date (ECA)^disc date ECDI^mov # ECDA^
+ ;type ECM^losing ward ECXWARD^treat spec ^los ECXLOS^^
+ ;movement type ECMT^mov time ECTM^gaining ward ECXWTO^
+ ;adm time (ECA)^^^
+ ;node1
+ ;mpi ECXMPI^dss dept ECXDSSD^dom ECXDOM^observ pat ind ECXOBS^
+ ;encounter num ECXENC^disch prim prov ECXDPR^disch PC team ECXDPCT^
+ ;disch assoc prim prov ECXDAPR^production division ECXPDIV
+ ;^disch prov person class ECXDPRPC^disch assoc prov pe-
+ ;rson person class
+ N DA,DIK
+ S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1
+ S ECODE=EC7_U_EC23_U_ECXFAC_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U
+ S ECODE=ECODE_$$ECXDATE^ECXUTL(ECD,ECXYM)_U_U
+ S ECODE=ECODE_$$ECXDATE^ECXUTL(ECA,ECXYM)_U_ECDI_U_ECDA_U_ECM_U_ECXWRD_U
+ S ECODE=ECODE_U_ECXLOS_U_U_ECMT_U_ECTM_U_ECXWTO_U
+ S ECODE=ECODE_$$ECXTIME^ECXUTL(ECA)_U_U_U
+ S ECODE1=ECXMPI_U_ECXDSSD_U_ECXDOM_U_ECXOBS_U_ECXENC_U_ECXDPR_U
+ S ECODE1=ECODE1_ECXDPCT_U_ECXDAPR_U_ECXPDIV ;p-46 added ECXPDIV
+ I ECXLOGIC>2005 S ECODE1=ECODE1_U_ECXDPRPC_U_ECXDAPPC
+ S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,ECRN=ECRN+1
+ S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA
+ I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1
+ Q
+ ;
+SETUP ;Set required input for ECXTRAC
+ S ECHEAD="MOV"
+ D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
+ Q
+ ;
+QUE ; entry point for the background requeuing handled by ECXTAUTO
+ D SETUP,QUE^ECXTAUTO,^ECXKILL Q

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXMTL.m

@@ -1 @@
-ECXMTL  ;ALB/JAP - DSS Mental Health Extract ; 8/17/07 9:52am
-        ;;3.0;DSS EXTRACTS;**24,30,33,39,46,49,71,82,84,92,105**;Dec 22, 1997;Build 70
-        ;
-BEG     ;entry point from option
-        D SETUP I ECFILE="" Q
-        D ^ECXTRAC,^ECXKILL
-        Q
-        ;
-START   ;entry point from tasked job
-        S QFLG=0
-        ;get first record #
-        S EC7=$O(^ECX(ECFILE,999999999),-1)
-        ;call mh/dss api for extract record creation
-        ;variables ecfile,ecxym,ecinst,ecsd,eced passed in by taskmanager
-        S ECXSEQ=EC7,ECXECX=$P(EC23,U,2),ECXERR=0
-        ;call mh api to create extract records
-        S X="YSDSS" X ^%ZOSF("TEST") I '$T S QFLG=1 Q
-        D UPD^YSDSS(ECFILE,.ECXSEQ,ECXYM,ECXECX,ECINST,ECSD,ECED,.ECXERR)
-        Q:ECXERR
-        Q:QFLG
-        ;if no error, continue
-        D UPDATE
-        Q
-        ;
-UPDATE  ;add non-mh data to each record created by mh api
-        N ECXADT,JJ,ECXNPRFI
-        S EC7=EC7+1
-        F JJ=EC7:1:ECXSEQ Q:QFLG  D
-        .Q:'$D(^ECX(ECFILE,JJ,0))
-        .S ECXDFN=$P(^ECX(ECFILE,JJ,0),U,5),ECXDATE=$P(^ECX(ECFILE,JJ,0),U,9),ECXPRV=$P(^ECX(ECFILE,JJ,0),U,18)
-        .S ECXSCNUM=$P(^ECX(ECFILE,JJ,0),U,23),ECXSCNAM=$P(^ECX(ECFILE,JJ,0),U,24)
-        .D PAT(ECXDFN,ECXDATE)
-        .S (ECXPRCLS,ECPRNPI,ECXDIV,ECXPDIV)="" I ECXPRV D PROV(.ECXPRV,ECXDATE)
-        .S ECXDSSI=""
-        .I ECXLOGIC>2003 D
-        ..I "^18^23^24^36^41^65^94^"[("^"_ECXTS_"^") S ECXDSSI=$$TSMAP^ECXUTL4(ECXTS)
-        .;
-        .;- Observation patient indicator (YES/NO)
-        .S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXDSSI)
-        .;
-        .;- set national patient record flag if exist
-        .D NPRF^ECXUTL5
-        .;
-        .;- If no encounter number don't file record
-        .S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADT,ECXDATE,ECXTS,ECXOBS,ECHEAD,,) Q:ECXENC=""
-        .S ECD=ECXDATE,ECXDATE=$$ECXDATE^ECXUTL(ECXDATE,ECXYM)
-        .;adjust scale name & scale number
-        .S ECXSCNAM=$E(ECXSCNAM,1,10)
-        .I ECXSCNUM]"",ECXSCNUM'=+ECXSCNUM S ECXSCNUM=+$E(ECXSCNUM,2,99)
-        .N ECXDEPT S ECXDEPT="" ;dss department use postponed S ECXDEPT=$$MTL^ECXDEPT(ECXDIV,ECXSCNAM,ECINST) ;p-46 line added
-        .;Set division to external value if extract is for FY05 or higher
-        .D FILE
-        Q
-        ;
-PAT(ECXDFN,ECXDATE)     ;determine in/outpatient status, demographics, primary care
-        N OK
-        S (ECXADT,ECXPNM,ECXSSN,ECXMPI)=""
-        K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,ECXDATE,"1;3;5;",.ECXPAT)
-        S ECXPNM=ECXPAT("NAME"),ECXSSN=ECXPAT("SSN"),ECXMPI=ECXPAT("MPI")
-        S ECXDOB=ECXPAT("DOB")
-        ;agent orange status
-        S ECXAST=ECXPAT("AO STAT")
-        ;- Purple Heart Indicator, Period of Service, Agent Orange Location
-        S ECXPHI=$G(ECXPAT("PHI")),ECXPOS=ECXPAT("POS"),ECXAOL=ECXPAT("AOL")
-        I $$ENROLLM^ECXUTL2(ECXDFN)
-        ;Combat Veteran Status
-        S X3=$$CVEDT^ECXUTL5(ECXDFN,$S($G(ECD):ECD,$G(ECXDATE):ECXDATE,1:DT))
-        ; - Head and Neck Cancer Indicator
-        S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN)
-        ; - Race and Ethnicity
-        S ECXETH=ECXPAT("ETHNIC")
-        S ECXRC1=ECXPAT("RACE1")
-        ;get primary care data
-        S X=$$PRIMARY^ECXUTL2(ECXDFN,ECXDATE),ECPTTM=$P(X,U)
-        S ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4)
-        S ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7)
-        ;get inpatient data
-        S X=$$INP^ECXUTL2(ECXDFN,ECXDATE),ECXDOM=$P(X,U,10),ECXTS=$P(X,U,3)
-        S ECXA=$P(X,U),(ECXADT,ECXADMDT)=$P($P(X,U,4),"."),ECXDCDT=$P($P(X,U,6),".")
-        S ECXWPRV=$P(X,U,7),ECXATT=$P(X,U,8)
-        S ECWPRNPI=$$NPI^XUSNPI("Individual_ID",ECXWPRV,ECXDATE)
-        S:+ECWPRNPI'>0 ECWPRNPI="" S ECWPRNPI=$P(ECWPRNPI,U)
-        S ECATTNPI=$$NPI^XUSNPI("Individual_ID",ECXATT,ECXDATE)
-        S:+ECATTNPI'>0 ECATTNPI="" S ECATTNPI=$P(ECATTNPI,U)
-        ;Get ward provider and attending phy person classes
-        S ECXWPRPC=$P(X,U,11),ECXATTPC=$P(X,U,12)
-        I ECXADMDT S ECXADMDT=$$ECXDATE^ECXUTL(ECXADMDT,ECXYM)
-        I ECXDCDT S ECXDCDT=$$ECXDATE^ECXUTL(ECXDCDT,ECXYM)
-        Q
-        ;
-PROV(ECXPRV,ECXDATE)    ;get provider data
-        N INST,DGIEN,ARR,DIC,DR,DA,DIQ
-        S ECXPRCLS=$$PRVCLASS^ECXUTL(ECXPRV,ECXDATE)
-        S ECPRNPI=$$NPI^XUSNPI("Individual_ID",ECXPRV,ECXDATE)
-        S:+ECPRNPI'>0 ECPRNPI="" S ECPRNPI=$P(ECPRNPI,U)
-        ;get division identifier using provider
-        S (ECXDIV,ECXPDIV)=""
-        S IEN=0 F  D  Q:'IEN  Q:'INST  Q:ECXDIV
-        .;get pointer to file #4 from provider record
-        .I '$D(^VA(200,ECXPRV,0)) Q
-        .S IEN=$O(^VA(200,ECXPRV,2,IEN))
-        .Q:'IEN
-        .S DIC="^VA(200,",DR="16",DA=ECXPRV
-        .S DR(200.02)=".01",DA(200.02)=IEN,DIQ="ARR",DIQ(0)="I"
-        .D EN^DIQ1
-        .S INST=$G(ARR(200.02,IEN,.01,"I"))
-        .Q:'INST
-        .;get production division
-        .S ECXPDIV=$$RADDIV^ECXDEPT(INST) ;p-46 line added
-        .;get medical center division
-        .S DGIEN=$O(^DG(40.8,"AD",INST,0)) I DGIEN D
-        ..S ECXDIV=$P($G(^ECX(727.3,DGIEN,0)),U,2)
-        S ECXPRV="2"_ECXPRV
-        Q
-        ;
-FILE    ;file record in #727.812
-        ;node0
-        ;facility^dfn^ssn ECXSSN^name ECXPNM^i/o status ECXA^
-        ;day ECXDATE^division ECXDIV^admit date ECXADMDT^
-        ;d/c date ECXDCDT^dss id ECXDSSI^pc team ECPTTM^pc provider ECPTPR^
-        ;placeholder^pc prov person class ECCLAS^
-        ;provider ECXPRV^placeholder^prov person class ECXPRCLS^
-        ;test name ECXSCNAM(?)^test ien ECXSCNUM(?)^scale number^scale name^
-        ;test score^scale score^attend phys^ward provider
-        ;node1
-        ;mpi^assoc pc provider^placeholder^
-        ;assoc pc prov person class^asi class^asi special^asi encounter date^
-        ;purple heart ind.^dom prrtp & saartp ind.^enrollment cat^
-        ;enrollment stat^enrollment prior^period of serv.^obs. pat ind.^
-        ;encounter num^agent orange loc^dob^production division^dss
-        ;department ECXDEPT^head & neck canc. indi.^ethnicity^race1^^
-        ;enrollment prior ECXPRIOR_enrollment subgroup
-        ;ECXSBGRP^enrollee user ECXUESTA^division ECXDIV^patient type
-        ;ECXPTYPE^combat vet elig ECXCVE^combat vet elig end date ECXCVEDT^
-        ;enc cv eligible ECXCVENC^national patient record flag ECXNPRFI
-        ;attending phy person class ECXATTPC^ward provider person class 
-        ;ECXWPRPC^^agent orange status ECXAST^asso prov npi ECASNPI^att phy
-        ;npi ECATTNPI^primary care prov npi ECPTNPI^provider npi ECPRNPI^ward
-        ;provider npi ECWPRNPI
-        N DA,DIK,STR
-        I $P(^ECX(ECFILE,JJ,0),U,21)="ASI" S $P(^ECX(ECFILE,JJ,1),U,7)=ECXDATE
-        S $P(^ECX(ECFILE,JJ,0),U,6,9)=ECXSSN_U_ECXPNM_U_ECXA_U_ECXDATE
-        S STR=$S(ECXLOGIC<2005:ECXDIV,1:"")_U_ECXADMDT_U_ECXDCDT_U_ECXDSSI_U_ECPTTM_U_ECPTPR_U
-        S STR=STR_U_ECCLAS,$P(^ECX(ECFILE,JJ,0),U,10,17)=STR,STR=""
-        S $P(^ECX(ECFILE,JJ,0),U,18,20)=ECXPRV_U_U_ECXPRCLS
-        S $P(^ECX(ECFILE,JJ,0),U,23,24)=ECXSCNUM_U_ECXSCNAM
-        S $P(^ECX(ECFILE,JJ,0),U,27,29)=ECXATT_U_ECXWPRV_U
-        I '$D(^ECX(ECFILE,JJ,1)) S ^ECX(727.812,JJ,1)="^^^^^"
-        S $P(^ECX(ECFILE,JJ,1),U,1,4)=ECXMPI_U_ECASPR_U_U_ECCLAS2
-        S STR=ECXPHI_U_ECXDOM_U_ECXCAT_U_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXPOS_U
-        S STR=STR_ECXOBS_U_ECXENC_U_ECXAOL_U_ECXDOB_U_ECXPDIV_U_ECXDEPT_U
-        S STR=STR_ECXHNCI_U_ECXETH_U_ECXRC1_U
-        I ECXLOGIC>2004 S STR=STR_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXDIV_U_ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXNPRFI
-        I ECXLOGIC>2005 S STR=STR_U_ECXATTPC_U_ECXWPRPC
-        S $P(^ECX(ECFILE,JJ,1),U,8,22)=STR
-        I ECXLOGIC>2006 S $P(^ECX(ECFILE,JJ,1),U,34)=ECXAST_U
-        I ECXLOGIC>2007 S $P(^ECX(ECFILE,JJ,1),U,35)=ECASNPI_U_ECATTNPI_U_ECPTNPI_U D
-        . S ^ECX(ECFILE,JJ,2)=ECPRNPI_U_ECWPRNPI
-        S DA=JJ,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA
-        S ECRN=ECRN+1
-        I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1
-        Q
-        ;
-SETUP   ;Set required input for ECXTRAC
-        S ECHEAD="MTL"
-        D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
-        Q
-        ;
-QUE     ;Entry point for the background requeuing handled by ECXTAUTO.
-        D SETUP,QUE^ECXTAUTO,^ECXKILL
-        Q
+ECXMTL ;ALB/JAP - DSS Mental Health Extract ; 9/11/06 11:07am
+ ;;3.0;DSS EXTRACTS;**24,30,33,39,46,49,71,82,84,92**;Dec 22, 1997;Build 30
+ ;
+BEG ;entry point from option
+ D SETUP I ECFILE="" Q
+ D ^ECXTRAC,^ECXKILL
+ Q
+ ;
+START ;entry point from tasked job
+ S QFLG=0
+ ;get first record #
+ S EC7=$O(^ECX(ECFILE,999999999),-1)
+ ;call mh/dss api for extract record creation
+ ;variables ecfile,ecxym,ecinst,ecsd,eced passed in by taskmanager
+ S ECXSEQ=EC7,ECXECX=$P(EC23,U,2),ECXERR=0
+ ;call mh api to create extract records
+ S X="YSDSS" X ^%ZOSF("TEST") I '$T S QFLG=1 Q
+ D UPD^YSDSS(ECFILE,.ECXSEQ,ECXYM,ECXECX,ECINST,ECSD,ECED,.ECXERR)
+ Q:ECXERR
+ Q:QFLG
+ ;if no error, continue
+ D UPDATE
+ Q
+ ;
+UPDATE ;add non-mh data to each record created by mh api
+ N ECXADT,JJ,ECXNPRFI
+ S EC7=EC7+1
+ F JJ=EC7:1:ECXSEQ Q:QFLG  D
+ .Q:'$D(^ECX(ECFILE,JJ,0))
+ .S ECXDFN=$P(^ECX(ECFILE,JJ,0),U,5),ECXDATE=$P(^ECX(ECFILE,JJ,0),U,9),ECXPRV=$P(^ECX(ECFILE,JJ,0),U,18)
+ .S ECXSCNUM=$P(^ECX(ECFILE,JJ,0),U,23),ECXSCNAM=$P(^ECX(ECFILE,JJ,0),U,24)
+ .D PAT(ECXDFN,ECXDATE)
+ .S (ECXPRCLS,ECXPRNPI,ECXDIV,ECXPDIV)="" I ECXPRV D PROV(.ECXPRV,ECXDATE)
+ .S ECXDSSI=""
+ .I ECXLOGIC>2003 D
+ ..I "^18^23^24^36^41^65^94^"[("^"_ECXTS_"^") S ECXDSSI=$$TSMAP^ECXUTL4(ECXTS)
+ .;
+ .;- Observation patient indicator (YES/NO)
+ .S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXDSSI)
+ .;
+ .;- set national patient record flag if exist
+ .D NPRF^ECXUTL5
+ .;
+ .;- If no encounter number don't file record
+ .S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADT,ECXDATE,ECXTS,ECXOBS,ECHEAD,,) Q:ECXENC=""
+ .S ECD=ECXDATE,ECXDATE=$$ECXDATE^ECXUTL(ECXDATE,ECXYM)
+ .;adjust scale name & scale number
+ .S ECXSCNAM=$E(ECXSCNAM,1,10)
+ .I ECXSCNUM]"",ECXSCNUM'=+ECXSCNUM S ECXSCNUM=+$E(ECXSCNUM,2,99)
+ .N ECXDEPT S ECXDEPT="" ;dss department use postponed S ECXDEPT=$$MTL^ECXDEPT(ECXDIV,ECXSCNAM,ECINST) ;p-46 line added
+ .;Set division to external value if extract is for FY05 or higher
+ .D FILE
+ Q
+ ;
+PAT(ECXDFN,ECXDATE) ;determine in/outpatient status, demographics, primary care
+ N OK
+ S (ECXADT,ECXPNM,ECXSSN,ECXMPI)=""
+ K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,ECXDATE,"1;3;5;",.ECXPAT)
+ S ECXPNM=ECXPAT("NAME"),ECXSSN=ECXPAT("SSN"),ECXMPI=ECXPAT("MPI")
+ S ECXDOB=ECXPAT("DOB")
+ ;agent orange status
+ S ECXAST=ECXPAT("AO STAT")
+ ;- Purple Heart Indicator, Period of Service, Agent Orange Location
+ S ECXPHI=$G(ECXPAT("PHI")),ECXPOS=ECXPAT("POS"),ECXAOL=ECXPAT("AOL")
+ I $$ENROLLM^ECXUTL2(ECXDFN)
+ ;Combat Veteran Status
+ S X3=$$CVEDT^ECXUTL5(ECXDFN,$S($G(ECD):ECD,$G(ECXDATE):ECXDATE,1:DT))
+ ; - Head and Neck Cancer Indicator
+ S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN)
+ ; - Race and Ethnicity
+ S ECXETH=ECXPAT("ETHNIC")
+ S ECXRC1=ECXPAT("RACE1")
+ ;get primary care data
+ S X=$$PRIMARY^ECXUTL2(ECXDFN,ECXDATE),ECPTTM=$P(X,U)
+ S ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4)
+ S ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7)
+ ;get inpatient data
+ S X=$$INP^ECXUTL2(ECXDFN,ECXDATE),ECXDOM=$P(X,U,10),ECXTS=$P(X,U,3)
+ S ECXA=$P(X,U),(ECXADT,ECXADMDT)=$P($P(X,U,4),"."),ECXDCDT=$P($P(X,U,6),".")
+ S ECXWPRV=$P(X,U,7),ECXATT=$P(X,U,8)
+ ;Get ward provider and attending phy person classes
+ S ECXWPRPC=$P(X,U,11),ECXATTPC=$P(X,U,12)
+ I ECXADMDT S ECXADMDT=$$ECXDATE^ECXUTL(ECXADMDT,ECXYM)
+ I ECXDCDT S ECXDCDT=$$ECXDATE^ECXUTL(ECXDCDT,ECXYM)
+ Q
+ ;
+PROV(ECXPRV,ECXDATE) ;get provider data
+ N INST,DGIEN,ARR,DIC,DR,DA,DIQ
+ S ECXPRCLS=$$PRVCLASS^ECXUTL(ECXPRV,ECXDATE)
+ S ECXPRNPI=""
+ ;get division identifier using provider
+ S (ECXDIV,ECXPDIV)=""
+ S IEN=0 F  D  Q:'IEN  Q:'INST  Q:ECXDIV
+ .;get pointer to file #4 from provider record
+ .I '$D(^VA(200,ECXPRV,0)) Q
+ .S IEN=$O(^VA(200,ECXPRV,2,IEN))
+ .Q:'IEN
+ .S DIC="^VA(200,",DR="16",DA=ECXPRV
+ .S DR(200.02)=".01",DA(200.02)=IEN,DIQ="ARR",DIQ(0)="I"
+ .D EN^DIQ1
+ .S INST=$G(ARR(200.02,IEN,.01,"I"))
+ .Q:'INST
+ .;get production division
+ .S ECXPDIV=$$RADDIV^ECXDEPT(INST) ;p-46 line added
+ .;get medical center division
+ .S DGIEN=$O(^DG(40.8,"AD",INST,0)) I DGIEN D
+ ..S ECXDIV=$P($G(^ECX(727.3,DGIEN,0)),U,2)
+ S ECXPRV="2"_ECXPRV
+ Q
+ ;
+FILE ;file record in #727.812
+ ;node0
+ ;facility^dfn^ssn ECXSSN^name ECXPNM^i/o status ECXA^
+ ;day ECXDATE^division ECXDIV^admit date ECXADMDT^
+ ;d/c date ECXDCDT^dss id ECXDSSI^pc team ECPTTM^pc provider ECPTPR^
+ ;pc provider npi ECPTNPI^pc prov person class ECCLAS^
+ ;provider ECXPRV^provider npi ECXPRNPI^prov person class ECXPRCLS^
+ ;test name ECXSCNAM(?)^test ien ECXSCNUM(?)^scale number^scale name^
+ ;test score^scale score^attend phys^ward provider
+ ;node1
+ ;mpi^assoc pc provider^assoc pc provider npi^
+ ;assoc pc prov person class^asi class^asi special^asi encounter date^
+ ;purple heart ind.^dom prrtp & saartp ind.^enrollment cat^
+ ;enrollment stat^enrollment prior^period of serv.^obs. pat ind.^
+ ;encounter num^agent orange loc^dob^production division^dss
+ ;department ECXDEPT^head & neck canc. indi.^ethnicity^race1^^
+ ;enrollment prior ECXPRIOR_enrollment subgroup
+ ;ECXSBGRP^enrollee user ECXUESTA^division ECXDIV^patient type
+ ;ECXPTYPE^combat vet elig ECXCVE^combat vet elig end date ECXCVEDT^
+ ;enc cv eligible ECXCVENC^national patient record flag ECXNPRFI
+ ;attending phy person class ECXATTPC^ward provider person class 
+ ;ECXWPRPC^^agent orange status ECXAST
+ N DA,DIK,STR
+ I $P(^ECX(ECFILE,JJ,0),U,21)="ASI" S $P(^ECX(ECFILE,JJ,1),U,7)=ECXDATE
+ S $P(^ECX(ECFILE,JJ,0),U,6,9)=ECXSSN_U_ECXPNM_U_ECXA_U_ECXDATE
+ S STR=$S(ECXLOGIC<2005:ECXDIV,1:"")_U_ECXADMDT_U_ECXDCDT_U_ECXDSSI_U_ECPTTM_U_ECPTPR_U
+ S STR=STR_ECPTNPI_U_ECCLAS,$P(^ECX(ECFILE,JJ,0),U,10,17)=STR,STR=""
+ S $P(^ECX(ECFILE,JJ,0),U,18,20)=ECXPRV_U_ECXPRNPI_U_ECXPRCLS
+ S $P(^ECX(ECFILE,JJ,0),U,23,24)=ECXSCNUM_U_ECXSCNAM
+ S $P(^ECX(ECFILE,JJ,0),U,27,29)=ECXATT_U_ECXWPRV_U
+ I '$D(^ECX(ECFILE,JJ,1)) S ^ECX(727.812,JJ,1)="^^^^^"
+ S $P(^ECX(ECFILE,JJ,1),U,1,4)=ECXMPI_U_ECASPR_U_ECASNPI_U_ECCLAS2
+ S STR=ECXPHI_U_ECXDOM_U_ECXCAT_U_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXPOS_U
+ S STR=STR_ECXOBS_U_ECXENC_U_ECXAOL_U_ECXDOB_U_ECXPDIV_U_ECXDEPT_U
+ S STR=STR_ECXHNCI_U_ECXETH_U_ECXRC1_U
+ I ECXLOGIC>2004 S STR=STR_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXDIV_U_ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXNPRFI
+ I ECXLOGIC>2005 S STR=STR_U_ECXATTPC_U_ECXWPRPC
+ S $P(^ECX(ECFILE,JJ,1),U,8,22)=STR
+ I ECXLOGIC>2006 S $P(^ECX(ECFILE,JJ,1),U,34)=ECXAST
+ S DA=JJ,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA
+ S ECRN=ECRN+1
+ I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1
+ Q
+ ;
+SETUP ;Set required input for ECXTRAC
+ S ECHEAD="MTL"
+ D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
+ Q
+ ;
+QUE ;Entry point for the background requeuing handled by ECXTAUTO.
+ D SETUP,QUE^ECXTAUTO,^ECXKILL
+ Q

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXNUT.m

@@ -1 @@
-ECXNUT  ;ALB/JRC Nutrition DSS Extract ; 9/24/07 9:33am
-        ;;3.0;DSS EXTRACTS;**92,107,105**;Dec 22, 1997;Build 70
-BEG     ;entry point from option
-        N EC23,EC7,ECED,ECFILE,ECGRP,ECHEAD,ECINST,ECPACK,ECPIECE,ECRN,ECRTN,ECSD1,ECVER,ECXYM
-        D SETUP I ECFILE="" Q
-        D ^ECXTRAC,^ECXKILL
-        Q
-        ;
-START   ; start package specific extract
-        ;Init variables
-        N ECSD,ARRAY
-        S ECED=ECED+.3,ECSD=ECSD1,ARRAY="^TMP($J,""FH"")"
-        K @ARRAY
-        ;
-        ;Call n&fs api and store in ^TMP($J,"FH" global
-        D DATA^FHDSSAPI(ECSD,ECED)
-        ;
-        ;Get n&fs records from ^TMP($J,"FH" global and file
-        D GETMEALS^ECXNUT1
-        ;
-        ;kill ^tmp global
-        K @ARRAY
-        ;
-        Q
-        ;
-GET     ;gather extract data
-        ;Init variables
-        N ECXORDPC,ECXSSN,ECXPNM,ECXSEX,ECXDOB,ECXMPI,ECXRC1,ECXETH,ECXVET,ECXENRL,ECXELIG,ECXMST,ECXPST,ECXPLOC,ECXPHI,ECXMNS,ECXSTATE,ECXCNTY,ECXZIP,ECXPOS,ECXAST,ECXAOL,ECXRST,ECXEST,ECXTM,ECXDATE,ECXMN,ECXSPC
-        N ECXADMDT,ECXWRD,ECXFAC,ECXPRV,ECXPRNPI,ECXATT,ECXATNPI,ECXDOM,ECXATTPC,ECXPRVPC,ECXPDIV,ECXCBOC,ECPTPR,ECCLASS,ECPTTM,ECXOBS,ECXHNCI,ECXNPRFI,ECXERI,ECXENC,ECPAT,ECXERR,ADM,W,X,ECXCAT,ECXCVE,ECXPRIOR,ECXPTYPE,ECXSTAT,ECXUESTA,ECXA,ECORNPI
-        N ECXOEF,ECXOEFDT
-        ;
-        ;- Prefix ordering pro with a 2 and get person class
-        S ECXORDPC=$$PRVCLASS^ECXUTL(+ECXORDPH,DATE)
-        S ECORNPI=$$NPI^XUSNPI("Individual_ID",+ECXORDPH,DATE)
-        S:+ECORNPI'>0 ECORNPI="" S ECORNPI=$P(ECORNPI,U)
-        S ECXORDPH=$S(ECXORDPH:2_ECXORDPH,1:"")
-        ;
-        ;set patient file (#2) dfn and get patient demographics
-        S ECXDFN=$P($G(^TMP($J,"FH","ZN",FHDFN)),U,3)
-        S ECXERR=0 D PAT(ECXDFN)
-        Q:ECXERR
-        ;Set demographic variables
-        S ECXSSN=ECPAT("SSN"),ECXPNM=ECPAT("NAME"),ECXSEX=ECPAT("SEX"),ECXDOB=ECPAT("DOB"),ECXMPI=ECPAT("MPI"),ECXRC1=ECPAT("RACE1"),ECXETH=ECPAT("ETHNIC"),ECXVET=ECPAT("VET"),ECXENRL=ECPAT("ENROLL LOC"),ECXELIG=ECPAT("ELIG")
-        S ECXMST=ECPAT("MST STAT"),ECXPST=ECPAT("POW STAT"),ECXPLOC=ECPAT("POW LOC"),ECXPHI=ECPAT("PHI"),ECXMNS=ECPAT("MEANS"),ECXSTATE=ECPAT("STATE"),ECXCNTY=ECPAT("COUNTY"),ECXZIP=ECPAT("ZIP")
-        S ECXPOS=ECPAT("POS"),ECXAST=ECPAT("AO STAT"),ECXAOL=ECPAT("AOL"),ECXRST=ECPAT("IR STAT"),ECXEST=ECPAT("EC STAT")
-        ;
-        ;Get oef/oif data
-        S ECXOEF=ECPAT("ECXOEF")
-        S ECXOEFDT=ECPAT("ECXOEFDT")
-        ;
-        ;Get enrollment status
-        I $$ENROLLM^ECXUTL2(ECXDFN)
-        ;
-        S ECXTM=$$ECXTIME^ECXUTL(DATE)
-        S ECXDATE=$$ECXDATE^ECXUTL(+DATE,ECXYM)
-        ;
-        ;- Use movement record date & time
-        S ADM=$$INP^ECXUTL2(ECXDFN,DATE),ECXA=$P(ADM,U)
-        S ECXMN=$P(ADM,U,2),ECXSPC=$P(ADM,U,3),ECXADMDT=$P(ADM,U,4)
-        S W=$P(ADM,U,9),ECXWRD=$P(W,";",1),ECXFAC=$P(W,";",2)
-        S ECXPRV=$P(ADM,U,7),ECXPRNPI="",ECXATT=$P(ADM,U,8),ECXATNPI=""
-        S ECXDOM=$P(ADM,U,10),ECXATTPC=$P(ADM,U,12),ECXPRVPC=$P(ADM,U,11)
-        ;
-        S ECXPDIV=$$GETDIV^ECXDEPT(ECXFAC)  ;Get production division
-        S ECXCBOC=$$CBOC^ECXSCX2(+ECXFAC) ;Get cboc facility
-        ;
-        ;- Get primary care data
-        S X=$$PRIMARY^ECXUTL2(ECXDFN,DATE)
-        S ECPTPR=$P(X,U,2),ECCLASS=$P(X,U,3),ECPTTM=$P(X,U),ECPTNPI=$P(X,U,4)
-        ;
-        ;- Observation patient indicator (YES/NO)
-        S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXSPC)
-        ;
-        ;- Get head and neck cancer indicator
-        S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN)
-        ;
-        ;- Get national patient record flag indicator
-        N ECXNPRFI D NPRF^ECXUTL5
-        ;
-        ;- National response indicator
-        S ECXERI=$$EMGRES^DGUTL(ECXDFN)
-        ;
-        ;- If null encounter number, don't file record
-        S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,DATE,ECXSPC,ECXOBS,ECHEAD,,)
-        D:ECXENC'="" FILE
-        Q
-        ;
-PAT(ECXDFN)     ;get/set patient data
-        ; INPUT - ECXDFN = patient ien (DFN)
-        ; OUTPUT - ECPAT array:
-        ;          ECPAT("SSN")
-        ;          ECPAT("NAME")
-        ; returns 0 or 1 in ECXERR - 0=successful
-        ;                            1=error condition
-        N X,OK
-        ;get data
-        S ECXERR=0
-        K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,"","1;2;3;5",.ECPAT)
-        I 'OK S ECXERR=1
-        Q ECXERR
-        ;
-FILE    ;file the n&fs extract record
-        ;node
-        ;facility^dfn^ssn^name^in/out^day^time^treating specialty^
-        ;ordering provider^ordering provider person class^primary 
-        ;care provider^primary person class^primary care team^mpi^dob^sex^
-        ;race 1^ethnicity^veteran^enrollment status^enrollment location^
-        ;enrollment category^enrollment priority^eligibility^period of
-        ;service^agent orange status^agent orange location^radiation status
-        ;^environmental contaminants^mst status^head & neck cancer indicator
-        ;pow status^pow location^purple heart indicator^means test^state code
-        ;^county code^zip+4^observation patient indicator^rrtp,prrtp and
-        ;saartp indicator^encounter number^patient division^food production
-        ;division^delivery division^product feeder key^food production
-        ;facility^delivery location type^delivery feeder location^quantity^
-        ;cboc^status^user enrollee^patient type^cv status eligibility^
-        ;national patient record flag^emergency response indicator^admission
-        ;date^oef/oif ECXOEF^oef/oif return date ECXOEFDT^ordering provider
-        ;npi ECORNPI^primary care provider npi ECPTNPI
-        ;
-        N DA,DIK,ECODE,ECODE1
-        S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1
-        S ECODE=EC7_U_EC23_U_ECINST_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U
-        ;
-        ;convert specialty to PTF Code
-        ;
-        N ECXDATA
-        S ECXDATA=$$TSDATA^DGACT(42.4,+ECXSPC,.ECXDATA)
-        S ECXSPC=$G(ECXDATA(7))
-        ;
-        S ECODE=ECODE_ECXDATE_U_ECXTM_U_ECXSPC_U_ECXORDPH_U_ECXORDPC_U
-        S ECODE=ECODE_ECPTPR_U_ECCLASS_U_ECPTTM_U_ECXMPI_U_ECXDOB_U_ECXSEX_U
-        S ECODE=ECODE_ECXRC1_U_ECXETH_U_ECXVET_U_ECXSTAT_U_ECXENRL_U_ECXCAT_U
-        S ECODE=ECODE_ECXPRIOR_U_ECXELIG_U_ECXPOS_U_ECXAST_U_ECXAOL_U_ECXRST
-        S ECODE=ECODE_U_ECXEST_U_ECXMST_U_ECXHNCI_U_ECXPST_U_ECXPLOC_U_ECXPHI
-        S ECODE=ECODE_U_ECXMNS_U_ECXSTATE_U_ECXCNTY_U
-        S ECODE1=ECXZIP_U_ECXOBS_U_ECXDOM_U_ECXENC_U_ECXPDIV_U_ECXFPD_U
-        S ECODE1=ECODE1_ECXFDD_U_ECXKEY_U_ECXFPF_U_ECXDLT_U_ECXDFL_U_ECXQTY_U
-        S ECODE1=ECODE1_ECXCBOC_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U_ECXNPRFI_U
-        S ECODE1=ECODE1_ECXERI_U_$S(ECXADMDT:$$ECXDATE^ECXUTL(ECXADMDT,ECXYM),1:"")
-        I ECXLOGIC>2007 S ECODE1=ECODE1_U_ECXOEF_U_ECXOEFDT_U_$G(ECXTFU)_U_ECORNPI_U_ECPTNPI
-        S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1
-        S ECRN=ECRN+1
-        S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA
-        Q
-        ;
-SETUP   ;Set required input for ECXTRAC.
-        S ECHEAD="NUT"
-        D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
-        Q
+ECXNUT ;ALB/JRC Nutrition DSS Extract ; 4/2/2007
+ ;;3.0;DSS EXTRACTS;**92,107**;Dec 22, 1997;Build 9
+BEG ;entry point from option
+ N EC23,EC7,ECED,ECFILE,ECGRP,ECHEAD,ECINST,ECPACK,ECPIECE,ECRN,ECRTN,ECSD1,ECVER,ECXYM
+ D SETUP I ECFILE="" Q
+ D ^ECXTRAC,^ECXKILL
+ Q
+ ;
+START ; start package specific extract
+ ;Init variables
+ N ECSD
+ S ECED=ECED+.3,ECSD=ECSD1
+ K ^TMP($J,"FH")
+ ;
+ ;Call n&fs api and store in ^TMP($J,"FH" global
+ D DATA^FHDSSAPI(ECSD,ECED)
+ ;
+ ;Get n&fs records from ^TMP($J,"FH" global and file
+ D GETMEALS^ECXNUT1
+ ;
+ ;kill ^tmp global
+ K ^TMP($J,"FH")
+ ;
+ Q
+ ;
+GET ;gather extract data
+ ;Init variables
+ N ECXORDPC,ECXSSN,ECXPNM,ECXSEX,ECXDOB,ECXMPI,ECXRC1,ECXETH,ECXVET,ECXENRL,ECXELIG,ECXMST,ECXPST,ECXPLOC,ECXPHI,ECXMNS,ECXSTATE,ECXCNTY,ECXZIP,ECXPOS,ECXAST,ECXAOL,ECXRST,ECXEST,ECXTM,ECXDATE,ECXMN,ECXSPC
+ N ECXADMDT,ECXWRD,ECXFAC,ECXPRV,ECXPRNPI,ECXATT,ECXATNPI,ECXDOM,ECXATTPC,ECXPRVPC,ECXPDIV,ECXCBOC,ECPTPR,ECCLASS,ECPTTM,ECXOBS,ECXHNCI,ECXNPRFI,ECXERI,ECXENC,ECPAT,ECXERR,ADM,W,X,ECXCAT,ECXCVE,ECXPRIOR,ECXPTYPE,ECXSTAT,ECXUESTA,ECXA
+ ;
+ ;- Prefix ordering pro with a 2 and get person class
+ S ECXORDPC=$$PRVCLASS^ECXUTL(+ECXORDPH,DATE)
+ S ECXORDPH=$S(ECXORDPH:2_ECXORDPH,1:"")
+ ;
+ ;set patient file (#2) dfn and get patient demographics
+ S ECXDFN=$P($G(^TMP($J,"FH","ZN",FHDFN)),U,3)
+ S ECXERR=0 D PAT(ECXDFN)
+ Q:ECXERR
+ ;Set demographic variables
+ S ECXSSN=ECPAT("SSN"),ECXPNM=ECPAT("NAME"),ECXSEX=ECPAT("SEX"),ECXDOB=ECPAT("DOB"),ECXMPI=ECPAT("MPI"),ECXRC1=ECPAT("RACE1"),ECXETH=ECPAT("ETHNIC"),ECXVET=ECPAT("VET"),ECXENRL=ECPAT("ENROLL LOC"),ECXELIG=ECPAT("ELIG")
+ S ECXMST=ECPAT("MST STAT"),ECXPST=ECPAT("POW STAT"),ECXPLOC=ECPAT("POW LOC"),ECXPHI=ECPAT("PHI"),ECXMNS=ECPAT("MEANS"),ECXSTATE=ECPAT("STATE"),ECXCNTY=ECPAT("COUNTY"),ECXZIP=ECPAT("ZIP")
+ S ECXPOS=ECPAT("POS"),ECXAST=ECPAT("AO STAT"),ECXAOL=ECPAT("AOL"),ECXRST=ECPAT("IR STAT"),ECXEST=ECPAT("EC STAT")
+ ;
+ ;Get enrollment status
+ I $$ENROLLM^ECXUTL2(ECXDFN)
+ ;
+ S ECXTM=$$ECXTIME^ECXUTL(DATE)
+ S ECXDATE=DATE
+ ;
+ ;- Use movement record date & time
+ S ADM=$$INP^ECXUTL2(ECXDFN,DATE),ECXA=$P(ADM,U)
+ S ECXMN=$P(ADM,U,2),ECXSPC=$P(ADM,U,3),ECXADMDT=$P(ADM,U,4)
+ S W=$P(ADM,U,9),ECXWRD=$P(W,";",1),ECXFAC=$P(W,";",2)
+ S ECXPRV=$P(ADM,U,7),ECXPRNPI="",ECXATT=$P(ADM,U,8),ECXATNPI=""
+ S ECXDOM=$P(ADM,U,10),ECXATTPC=$P(ADM,U,12),ECXPRVPC=$P(ADM,U,11)
+ ;
+ S ECXPDIV=$$GETDIV^ECXDEPT(ECXFAC)  ;Get production division
+ S ECXCBOC=$$CBOC^ECXSCX2(+ECXFAC) ;Get cboc facility
+ ;
+ ;- Get primary care data
+ S X=$$PRIMARY^ECXUTL2(ECXDFN,DATE)
+ S ECPTPR=$P(X,U,2),ECCLASS=$P(X,U,3),ECPTTM=$P(X,U)
+ ;
+ ;- Observation patient indicator (YES/NO)
+ S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXSPC)
+ ;
+ ;- Get head and neck cancer indicator
+ S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN)
+ ;
+ ;- Get national patient record flag indicator
+ N ECXNPRFI D NPRF^ECXUTL5
+ ;
+ ;- National response indicator
+ S ECXERI=$$EMGRES^DGUTL(ECXDFN)
+ ;
+ ;- If null encounter number, don't file record
+ S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,DATE,ECXSPC,ECXOBS,ECHEAD,,)
+ D:ECXENC'="" FILE
+ Q
+ ;
+PAT(ECXDFN) ;get/set patient data
+ ; INPUT - ECXDFN = patient ien (DFN)
+ ; OUTPUT - ECPAT array:
+ ;          ECPAT("SSN")
+ ;          ECPAT("NAME")
+ ; returns 0 or 1 in ECXERR - 0=successful
+ ;                            1=error condition
+ N X,OK
+ ;get data
+ S ECXERR=0
+ K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,"","1;2;3;5",.ECPAT)
+ I 'OK S ECXERR=1
+ Q ECXERR
+ ;
+FILE ;file the n&fs extract record
+ ;node
+ ;facility^dfn^ssn^name^in/out^day^time^treating specialty^
+ ;ordering provider^ordering provider person class^primary 
+ ;care provider^primary person class^primary care team^mpi^dob^sex^
+ ;race 1^ethnicity^veteran^enrollment status^enrollment location^
+ ;enrollment category^enrollment priority^eligibility^period of
+ ;service^agent orange status^agent orange location^radiation status
+ ;^environmental contaminants^mst status^head & neck cancer indicator
+ ;pow status^pow location^purple heart indicator^means test^state code
+ ;^county code^zip+4^observation patient indicator^rrtp,prrtp and
+ ;saartp indicator^encounter number^patient division^food production
+ ;division^delivery division^product feeder key^food production
+ ;facility^delivery location type^delivery feeder location^quantity^
+ ;cboc^status^user enrollee^patient type^cv status eligibility^
+ ;national^patient record flag^emergency response indicator^admission
+ ;date
+ ;
+ N DA,DIK,ECODE,ECODE1
+ S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1
+ S ECODE=EC7_U_EC23_U_ECINST_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U
+ ;
+ ;convert specialty to PTF Code
+ ;
+ N ECXDATA
+ S ECXDATA=$$TSDATA^DGACT(42.4,+ECXSPC,.ECXDATA)
+ S ECXSPC=$G(ECXDATA(7))
+ ;
+ S ECODE=ECODE_$$ECXDATE^ECXUTL(DATE,ECXYM)_U_ECXTM_U_ECXSPC_U_ECXORDPH_U_ECXORDPC_U
+ S ECODE=ECODE_ECPTPR_U_ECCLASS_U_ECPTTM_U_ECXMPI_U_ECXDOB_U_ECXSEX_U
+ S ECODE=ECODE_ECXRC1_U_ECXETH_U_ECXVET_U_ECXSTAT_U_ECXENRL_U_ECXCAT_U
+ S ECODE=ECODE_ECXPRIOR_U_ECXELIG_U_ECXPOS_U_ECXAST_U_ECXAOL_U_ECXRST
+ S ECODE=ECODE_U_ECXEST_U_ECXMST_U_ECXHNCI_U_ECXPST_U_ECXPLOC_U_ECXPHI
+ S ECODE=ECODE_U_ECXMNS_U_ECXSTATE_U_ECXCNTY_U
+ S ECODE1=ECXZIP_U_ECXOBS_U_ECXDOM_U_ECXENC_U_ECXPDIV_U_ECXFPD_U
+ S ECODE1=ECODE1_ECXFDD_U_ECXKEY_U_ECXFPF_U_ECXDLT_U_ECXDFL_U_ECXQTY_U
+ S ECODE1=ECODE1_ECXCBOC_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U_ECXNPRFI_U
+ S ECODE1=ECODE1_ECXERI_U_$S(ECXADMDT:$$ECXDATE^ECXUTL(ECXADMDT,ECXYM),1:"")
+ S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1
+ S ECRN=ECRN+1
+ S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA
+ Q
+ ;
+SETUP ;Set required input for ECXTRAC.
+ S ECHEAD="NUT"
+ D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
+ Q

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXNUT1.m

@@ -1 @@
-ECXNUT1 ;ALB/JRC Nutrition DSS Extract ; 11/23/07 12:27pm
-        ;;3.0;DSS EXTRACTS;**92,107,105**;Dec 22, 1997;Build 70
-        Q
-GETMEALS        ;get patient meals 
-        ; variable names:   ordate - regular diet order date
-        ;                   sdate  - diet order npo/withhold date
-        ;                   norder - "sf" or "so" order date
-        ;                             note: there is a relationship
-        ;                             between "sf", "so" and regular diets
-        ;                   adate - admission date
-        ;                   ddate - discharge date
-        N I,J,P,D,ECXADM,FHDFN,ORDATE,DATES,NODE,SF,PRODUCT,ECXQTY,ORDER,ECXORDPH,ECXKEY,ECXFPD,ECXFDD,ECXFPF,ECXDLT,ECXDFL,MEAL,MEALS,SORDATE,NUMBER,TF,TFNODE,ECXTFU,SDATE
-        ;set ecsd to first day of the month before setting meals array
-        S ECSD=ECSD+.1,ECXTFU=""
-        ;setup individual meals array for inpatients
-        F I=ECSD:1:ECED F J=I+.0800,I+.1300,I+.1800 S MEALS(J)=J
-        ;get "inp", "sf", and "so" inpatient meals
-        S ECXADM=0 F  S ECXADM=$O(@ARRAY@(ECXADM)) Q:'ECXADM  D
-        .S FHDFN=0 F  S FHDFN=$O(@ARRAY@(ECXADM,FHDFN)) Q:'FHDFN  D
-        ..S ORDATE=0,(ADATE,DDATE,SDATE)=""
-        ..F  S ORDATE=$O(@ARRAY@(ECXADM,FHDFN,ORDATE)) Q:'ORDATE  D
-        ...Q:$P($G(^TMP($J,"FH",ECXADM,FHDFN,+ORDATE,"INP")),U,7)'=""
-        ...S DATES=$$GETDATES(),SDATE=ORDATE
-        ...;create regular diet individual meals
-        ...S P="INP",D="PD"
-        ...;get new order date and time if exist
-        ...S NORDER=$$NEWORDER(D,ORDATE)
-        ...S NODE=$G(^TMP($J,"FH",ECXADM,FHDFN,ORDATE,"INP")) Q:'NODE
-        ...S PRODUCT=$P(NODE,U,13),ECXQTY=1,ORDER=""_$P(NODE,U,14)_","_""
-        ...;Resolve feeder key for nutrition product
-        ...S ECXKEY=$$NUTKEY^ECXUTL6(D,PRODUCT)
-        ...I $$NUTLOC^ECXUTL6(P,D,.ECXFPD,.ECXFDD,.ECXFPF,.ECXDLT,.ECXDFL)
-        ...S MEAL=ORDATE F  S MEAL=$O(MEALS(MEAL)) Q:'MEAL  D
-        ....I $P(DATES,U) Q:MEAL>$P(DATES,U)
-        ....I NORDER]"" Q:MEAL>NORDER
-        ....I $P(DATES,U,3) Q:MEAL>$P(DATES,U,3)
-        ....S ECXORDPH=$$GET1^DIQ(100,+ORDER,1,"I")
-        ....;Get additional data and file record.
-        ....S DATE=MEAL D GET^ECXNUT
-        ;create supplemental feeding meals if they exist
-        S ECXADM=0 F  S ECXADM=$O(@ARRAY@(ECXADM)) Q:'ECXADM  D
-        .S FHDFN=0 F  S FHDFN=$O(@ARRAY@(ECXADM,FHDFN)) Q:'FHDFN  D
-        ..S ORDATE=0,(ADATE,DDATE,SDATE)=""
-        ..F  S ORDATE=$O(@ARRAY@(ECXADM,FHDFN,ORDATE)) Q:'ORDATE  D
-        ...S DATES=$$GETDATES()
-        ...;get "sf" orders if they exist
-        ...N SFNODE S (SFNODE,ECXORDPH,CDATE)=""
-        ...S SFNODE=$G(@ARRAY@(ECXADM,FHDFN,ORDATE,"SF"))
-        ...I +SFNODE D
-        ....S P="INP",D="SF"
-        ....;get new order date and time if exist
-        ....S NORDER=$$NEWORDER(D,ORDATE),CDATE=$P(SFNODE,U,32)
-        ....;order thru all "sf" product fields and generate records
-        ....F SF=5:2:27 S PRODUCT=$P(SFNODE,U,SF) S ECXQTY=$P(SFNODE,U,(SF+1)) D
-        .....Q:PRODUCT']""
-        .....;Resolve external value for product key
-        .....S ECXKEY=$$NUTKEY^ECXUTL6("SF",PRODUCT)
-        .....I $$NUTLOC^ECXUTL6(P,D,.ECXFPD,.ECXFDD,.ECXFPF,.ECXDLT,.ECXDFL)
-        .....;create individual meals
-        .....F MEAL=ECSD:1:ECED D
-        ......I CDATE]"" Q:MEAL>CDATE
-        ......I NORDER]"" Q:MEAL>NORDER
-        ......I $P(DATES,U,3)]"" Q:MEAL>$P(DATES,U,3)
-        ......;Get additional data and file record.
-        ......S DATE=$P(MEAL,".")_"."_$S("57911"[SF:10,"13151719"[SF:14,1:18)
-        ......D GET^ECXNUT
-        ;create standing order meals if they exist
-        S ECXADM=0 F  S ECXADM=$O(@ARRAY@(ECXADM)) Q:'ECXADM  D
-        .S FHDFN=0 F  S FHDFN=$O(@ARRAY@(ECXADM,FHDFN)) Q:'FHDFN  D
-        ..S ORDATE=0,(ADATE,DDATE,SDATE)=""
-        ..F  S ORDATE=$O(@ARRAY@(ECXADM,FHDFN,ORDATE)) Q:'ORDATE  D
-        ...S DATES=$$GETDATES()
-        ...N SONODE,NUM S (SONODE,ECXORDPH)="",NUM=0
-        ...S NUM=$O(@ARRAY@(ECXADM,FHDFN,ORDATE,"SO",NUM)) Q:'NUM  D
-        ....S SONODE=$G(@ARRAY@(ECXADM,FHDFN,ORDATE,"SO",NUM))
-        ....I +SONODE D
-        .....;create standing order meals
-        .....N SMEAL S P="INP",D="SO"
-        .....;get new order date and time if exist
-        .....S NORDER=$$NEWORDER(D,ORDATE),SMEAL=$P(SONODE,U,3)
-        .....S PRODUCT=$P(SONODE,U,2),ECXQTY=$P(SONODE,U,8)
-        .....;Resolve feeder key for nutrition product
-        .....S ECXKEY=$$NUTKEY^ECXUTL6(D,PRODUCT)
-        .....I $$NUTLOC^ECXUTL6(P,D,.ECXFPD,.ECXFDD,.ECXFPF,.ECXDLT,.ECXDFL)
-        .....;create individual meals
-        .....S MEAL=ORDATE F  S MEAL=$O(MEALS(MEAL)) Q:'MEAL  D
-        ......N TIME S TIME=$P(MEALS(MEAL),".",2)
-        ......Q:SMEAL'["B"&(TIME=08)
-        ......Q:SMEAL'["N"&(TIME=13)
-        ......Q:SMEAL'["E"&(TIME=18)
-        ......I $P(DATES,U) Q:MEAL>$P(DATES,U)
-        ......I NORDER]"" Q:MEAL>NORDER
-        ......I $P(DATES,U,3) Q:MEAL>$P(DATES,U,3)
-        ......;Get additional data and file record.
-        ......S DATE=MEAL D GET^ECXNUT
-        ;remove individual meals array
-        K MEALS
-        ;Get inpatient tube feedings
-        N P1,PNODE,CDATE,ECXTFU,MEALS
-        ;set daily meals array for inpatient tube feedings
-        F I=ECSD:1:ECED S MEALS(I)=""
-        S (FHDFN,DATE,P1,CDATE)=0,(ECXADM,NODE,ECXORDPH,PNODE)=""
-        S P="INP",D="TF" F  S ECXADM=$O(^TMP($J,"FH",ECXADM)) Q:'ECXADM  D
-        .F  S FHDFN=$O(^TMP($J,"FH",ECXADM,FHDFN))  Q:'FHDFN  D
-        ..F  S DATE=$O(^TMP($J,"FH",ECXADM,FHDFN,DATE)) Q:'DATE  D
-        ...S NODE=$G(^TMP($J,"FH",ECXADM,FHDFN,DATE,"TF")) Q:'NODE  D
-        ....F  S P1=$O(^TMP($J,"FH",ECXADM,FHDFN,DATE,"TF",P1)) Q:'P1  D
-        .....S PNODE=^TMP($J,"FH",ECXADM,FHDFN,DATE,"TF",P1,"P")
-        .....S ORDATE=DATE,DATES=$$GETDATES(),CDATE=$P(NODE,U,11)
-        .....S PRODUCT=$P(PNODE,U,1),ORDER=""_$P(NODE,U,14)_","_""
-        .....S ECXQTY=$S($P(PNODE,U,3)["GM":$P(PNODE,U,3),1:$P(PNODE,U,4))
-        .....S ECXTFU=$S($P(PNODE,U,3)["GM":"GM",1:"ML")
-        .....;Resolve external value for product key
-        .....S ECXKEY=$$NUTKEY^ECXUTL6(D,PRODUCT)
-        .....I $$NUTLOC^ECXUTL6(P,D,.ECXFPD,.ECXFDD,.ECXFPF,.ECXDLT,.ECXDFL)
-        .....;create daily meals
-        .....S MEAL=DATE F  S MEAL=$O(MEALS(MEAL)) Q:'MEAL  D
-        ......I $P(DATES,U) Q:MEAL>$P(DATES,U)
-        ......I CDATE]"" Q:MEAL>CDATE
-        ......I $P(DATES,U,3) Q:MEAL>$P(DATES,U,3)
-        ......S ECXORDPH=$$GET1^DIQ(100,ORDER,1,"I")
-        ......;Get additional data and file record.
-        ......S DATE=MEAL D GET^ECXNUT S DATE=ORDATE
-        ;Get outpatient recurring meals
-        S DATE=0,(ECXADM,NODE,ECXORDPH,ECXTFU)=""
-        S P="OP",D="RM" F  S DATE=$O(^TMP($J,"FH",DATE)) Q:'DATE  D
-        . S FHDFN=0 F  S FHDFN=$O(^TMP($J,"FH",DATE,FHDFN))  Q:'FHDFN  D
-        .. S NUMBER=0 F  S NUMBER=$O(^TMP($J,"FH",DATE,FHDFN,NUMBER)) Q:'NUMBER  D
-        ... S NODE=$G(^TMP($J,"FH",DATE,FHDFN,NUMBER,"RM")) Q:'NODE
-        ... S PRODUCT=$P(NODE,U,2),ECXQTY=1,ORDER=""_$P(NODE,U,12)_","_""
-        ... S PRODUCT=$$GET1^DIQ(111,PRODUCT,4,"I")
-        ... S ECXORDPH=$$GET1^DIQ(100,ORDER,1,"I")
-        ... ;Resolve external value for product key
-        ... S ECXKEY=$$NUTKEY^ECXUTL6("PD",PRODUCT)
-        ... I $$NUTLOC^ECXUTL6(P,D,.ECXFPD,.ECXFDD,.ECXFPF,.ECXDLT,.ECXDFL)
-        ... ;Get additional data and file record.
-        ... D GET^ECXNUT
-        ;Get outpatient tube feedings
-        S DATE=0,(ECXADM,NODE,ECXORDPH)=""
-        S P="OP",D="TF" F  S DATE=$O(^TMP($J,"FH",DATE)) Q:'DATE  D
-        . S FHDFN=0 F  S FHDFN=$O(^TMP($J,"FH",DATE,FHDFN))  Q:'FHDFN  D
-        .. S NUMBER=0 F  S NUMBER=$O(^TMP($J,"FH",DATE,FHDFN,NUMBER)) Q:'NUMBER  D
-        ... S NODE=$G(^TMP($J,"FH",DATE,FHDFN,NUMBER,"RMTF")) Q:NODE=""
-        ... S TF=0 F  S TF=$O(^TMP($J,"FH",DATE,FHDFN,NUMBER,"RMTF",TF)) Q:'TF  D
-        .... S TFNODE=^TMP($J,"FH",DATE,FHDFN,NUMBER,"RMTF",TF)
-        .... S PRODUCT=$P(TFNODE,U,1),ECXQTY=$P(TFNODE,U,4)
-        .... ;Resolve external value for product key
-        .... S ECXKEY=$$NUTKEY^ECXUTL6("TF",PRODUCT)
-        .... I $$NUTLOC^ECXUTL6(P,D,.ECXFPD,.ECXFDD,.ECXFPF,.ECXDLT,.ECXDFL)
-        .... ;Get additional data and file record.
-        .... D GET^ECXNUT
-        ;Get outpatient special meals
-        S (FHDFN,DATE)=0,(ECXADM,NODE,ECXORDPH)=""
-        S P="OP",D="SM" F  S DATE=$O(^TMP($J,"FH",DATE)) Q:'DATE  D
-        . F  S FHDFN=$O(^TMP($J,"FH",DATE,FHDFN)) Q:'FHDFN  D
-        .. S NODE=$G(^TMP($J,"FH",DATE,FHDFN,"SM")) Q:'NODE
-        .. S PRODUCT=$P(NODE,U,4),ECXQTY=1,ECXORDPH=$P(NODE,U,5)
-        .. S PRODUCT=$$GET1^DIQ(111,PRODUCT,4,"I")
-        .. ;Resolve external value for product key
-        .. S ECXKEY=$$NUTKEY^ECXUTL6("SM",PRODUCT)
-        .. I $$NUTLOC^ECXUTL6(P,D,.ECXFPD,.ECXFDD,.ECXFPF,.ECXDLT,.ECXDFL)
-        .. ;Get additional data and file record.
-        .. D GET^ECXNUT
-        ;Get outpatient guest meals
-        S (FHDFN,DATE)=0,(ECXADM,NODE,ECXORDPH)=""
-        S P="OP",D="GM" F  S DATE=$O(^TMP($J,"FH",DATE)) Q:'DATE  D
-        . F  S FHDFN=$O(^TMP($J,"FH",DATE,FHDFN)) Q:'FHDFN  D
-        .. S NODE=$G(^TMP($J,"FH",DATE,FHDFN,"GM")) Q:'NODE
-        .. S PRODUCT=$P(NODE,U,13),ECXQTY=1
-        .. ;Resolve external value for product key
-        .. S ECXKEY=$$NUTKEY^ECXUTL6("GM",PRODUCT)
-        .. I $$NUTLOC^ECXUTL6(P,D,.ECXFPD,.ECXFDD,.ECXFPF,.ECXDLT,.ECXDFL)
-        .. ;Get additional data and file record.
-        .. D GET^ECXNUT
-        Q
-GETDATES()      ;Get admit, discharge, npo/withhold dates,for "inp", "sf" and "so"
-        ;  return in string i.e.  stop date^admission date^discharge date
-        ;     input:    ecxadm  -  movement file ien
-        ;               fhdfn   - nutrition patient file (#115)
-        ;
-        ;     output:   stop date  - npo/withhold date
-        ;               admit date - admission date and time
-        ;               discharge date - discharge date and time
-        ;init variables
-        N ADATE,DDATE,DATE,STDATE,NORDATE,IENS
-        ;check input
-        Q:'$G(ECXADM)!'$G(FHDFN) "0^0^0"
-        ;get admission and discharge dates
-        S (ADATE,DDATE,DATE,SDATE,NORDATE,STDATE)="",IENS=""_ECXADM_","_FHDFN_","_"",ADATE=$$GET1^DIQ(115.01,IENS,.01,"I"),DDATE=$$GET1^DIQ(115.01,IENS,18,"I")
-        ;get "inp" order's npo/withhold date return it as 'stdate' if exist
-        S DATE=ORDATE F  S DATE=$O(@ARRAY@(ECXADM,FHDFN,DATE)) Q:'DATE  D
-        .I $P($G(@ARRAY@(ECXADM,FHDFN,+DATE,"INP")),U,7)'="" S STDATE=DATE
-        Q STDATE_U_ADATE_U_DDATE
-NEWORDER(TYPE,DATE)     ;Look for new order for inpatient meal type if exist
-        ;    Input     ecxadm -  movement #
-        ;              fhdfn  -  nutrition file (#115) fhdfn
-        ;              date   -  starting order date to begin lookup
-        ;              type   -  meal type "sf", "so", or "pd"
-        ;    Output:   new order date and time for specific meal type
-        ;init variables
-        N NORDER
-        S NORDER=""
-        ;check input
-        Q:$G(TYPE)']""!'$G(DATE) NORDER
-        F  S DATE=$O(@ARRAY@(ECXADM,FHDFN,DATE)) Q:'DATE  Q:NORDER  D
-        .S NODE=$G(^TMP($J,"FH",ECXADM,FHDFN,DATE,TYPE)) Q:'NODE
-        .S NORDER=DATE
-        Q NORDER
+ECXNUT1 ;ALB/JRC Nutrition DSS Extract ; 10/27/06 1:53pm
+ ;;3.0;DSS EXTRACTS;**92**;Dec 22, 1997;Build 30
+ Q
+ ;
+GETMEALS ;get patient meals 
+ ;init variables
+ N DATE,FHDFN,ECXADM,NODE,PRODUCT,ECXQTY,ORDER,ECXORDPH,ECXKEY,P,D
+ N ECXFPD,ECXFDD,ECXFPF,ECXDLT,ECXDFL,NUMBER,PNODE,SF,TF,TFNODE
+ ;S (DATE,FHDFN,NUMBER,ECXQTY)=0,(ECXADM,NODE,ORDER,ECXORDPH)=""
+ ;Get inpatient diets
+ ;S P="INP",D="PD" F  S DATE=$O(^TMP($J,"FH",DATE)) Q:'DATE  D
+ ;. F  S FHDFN=$O(^TMP($J,"FH",DATE,FHDFN))  Q:'FHDFN  D
+ ;.. F  S ECXADM=$O(^TMP($J,"FH",DATE,FHDFN,ECXADM)) Q:'ECXADM  D
+ ;... S NODE=$G(^TMP($J,"FH",DATE,FHDFN,ECXADM,"INP")) Q:'NODE
+ ;... S PRODUCT=$P(NODE,U,13),ECXQTY=1,ORDER=""_$P(NODE,U,14)_","_""
+ ;... S ECXORDPH=$$GET1^DIQ(100,+ORDER,1,"I")
+ ;... ;Resolve feeder key for nutrition product
+ ;... S ECXKEY=$$NUTKEY^ECXUTL6("PD",PRODUCT)
+ ;... I $$NUTLOC^ECXUTL6(P,D,.ECXFPD,.ECXFDD,.ECXFPF,.ECXDLT,.ECXDFL)
+ ;... ;Get additional data and file record.
+ ;... D GET^ECXNUT
+ ;Get inpatient supplemental feedings
+ ;S (FHDFN,DATE)=0,(ECXADM,NODE,ORDER,ECXORDPH)=""
+ ;S P="INP",D="SF" F  S DATE=$O(^TMP($J,"FH",DATE)) Q:'DATE  D
+ ;. F  S FHDFN=$O(^TMP($J,"FH",DATE,FHDFN)) Q:'FHDFN  D
+ ;.. F  S ECXADM=$O(^TMP($J,"FH",DATE,FHDFN,ECXADM)) Q:'ECXADM  D
+ ;... S NODE=$G(^TMP($J,"FH",DATE,FHDFN,ECXADM,"SF")) Q:'NODE
+ ;... F SF=5:2:27 S PRODUCT=$P(NODE,U,SF) Q:PRODUCT']""  S ECXQTY=1 D
+ ;.... S ORDER=""_$P(NODE,U,7)_","_""
+ ;.... S ECXORDPH=$$GET1^DIQ(100,ORDER,1,"I")
+ ;.... ;Resolve external value for product key
+ ;.... S ECXKEY=$$NUTKEY^ECXUTL6("SF",PRODUCT)
+ ;.... I $$NUTLOC^ECXUTL6(P,D,.ECXFPD,.ECXFDD,.ECXFPF,.ECXDLT,.ECXDFL)
+ ;.... ;Get additional data and file record.
+ ;.... D GET^ECXNUT
+ ;Get inpatient standing orders
+ ;S (FHDFN,DATE)=0,(ECXADM,NODE,ECXORDPH)=""
+ ;S P="INP",D="SO" F  S DATE=$O(^TMP($J,"FH",DATE)) Q:'DATE  D
+ ;. F  S FHDFN=$O(^TMP($J,"FH",DATE,FHDFN)) Q:'FHDFN  D
+ ;.. F  S ECXADM=$O(^TMP($J,"FH",DATE,FHDFN,ECXADM)) Q:'ECXADM  D
+ ;... S NODE=$G(^TMP($J,"FH",DATE,FHDFN,ECXADM,"SO")) Q:'NODE
+ ;... S PRODUCT=$P(NODE,U,2),ECXQTY=1
+ ;... ;Resolve external value for product key
+ ;... S ECXKEY=$$NUTKEY^ECXUTL6("SO",PRODUCT)
+ ;... I $$NUTLOC^ECXUTL6(P,D,.ECXFPD,.ECXFDD,.ECXFPF,.ECXDLT,.ECXDFL)
+ ;... ;Get additional data and file record.
+ ;... D GET^ECXNUT
+ ;Get inpatient tube feedings
+ ;S (FHDFN,DATE,P)=0,(ECXADM,NODE,ECXORDPH,PNODE)=""
+ ;S P="INP",D="TF" F  S DATE=$O(^TMP($J,"FH",DATE)) Q:'DATE  D
+ ;. F  S FHDFN=$O(^TMP($J,"FH",DATE,FHDFN))  Q:'FHDFN  D
+ ;.. F  S ECXADM=$O(^TMP($J,"FH",DATE,FHDFN,ECXADM)) Q:'ECXADM  D
+ ;... S NODE=$G(^TMP($J,"FH",DATE,FHDFN,ECXADM,"TF")) Q:'NODE
+ ;... S P=$O(^TMP($J,"FH",DATE,FHDFN,ECXADM,"TF",P)) Q:'P  D
+ ;.... S PNODE=^TMP($J,"FH",DATE,FHDFN,ECXADM,"TF",P,"P")
+ ;.... S PRODUCT=$P(PNODE,U,1),ECXQTY=$P(PNODE,U,4)
+ ;.... S ORDER=""_$P(NODE,U,14)_","_""
+ ;.... S ECXORDPH=$$GET1^DIQ(100,ORDER,1,"I")
+ ;.... ;Resolve external value for product key
+ ;.... S ECXKEY=$$NUTKEY^ECXUTL6("TF",PRODUCT)
+ ;.... I $$NUTLOC^ECXUTL6(P,D,.ECXFPD,.ECXFDD,.ECXFPF,.ECXDLT,.ECXDFL)
+ ;.... ;Get additional data and file record.
+ ;.... D GET^ECXNUT
+ ;Get outpatient recurring meals
+ S (FHDFN,DATE)=0,(ECXADM,NODE,ECXORDPH)=""
+ S P="OP",D="RM" F  S DATE=$O(^TMP($J,"FH",DATE)) Q:'DATE  D
+ . F  S FHDFN=$O(^TMP($J,"FH",DATE,FHDFN))  Q:'FHDFN  D
+ .. S NUMBER=0 F  S NUMBER=$O(^TMP($J,"FH",DATE,FHDFN,NUMBER)) Q:'NUMBER  D
+ ... S NODE=$G(^TMP($J,"FH",DATE,FHDFN,NUMBER,"RM")) Q:'NODE
+ ... S PRODUCT=$P(NODE,U,2),ECXQTY=1,ORDER=""_$P(NODE,U,12)_","_""
+ ... S PRODUCT=$$GET1^DIQ(111,PRODUCT,4,"I")
+ ... S ECXORDPH=$$GET1^DIQ(100,ORDER,1,"I")
+ ... ;Resolve external value for product key
+ ... S ECXKEY=$$NUTKEY^ECXUTL6("PD",PRODUCT)
+ ... I $$NUTLOC^ECXUTL6(P,D,.ECXFPD,.ECXFDD,.ECXFPF,.ECXDLT,.ECXDFL)
+ ... ;Get additional data and file record.
+ ... D GET^ECXNUT
+ ;Get outpatient tube feedings
+ S (FHDFN,DATE,NUMBER)=0,(ECXADM,NODE,ECXORDPH)=""
+ S P="OP",D="TF" F  S DATE=$O(^TMP($J,"FH",DATE)) Q:'DATE  D
+ . F  S FHDFN=$O(^TMP($J,"FH",DATE,FHDFN))  Q:'FHDFN  D
+ .. F  S NUMBER=$O(^TMP($J,"FH",DATE,FHDFN,NUMBER)) Q:'NUMBER  D
+ ... S NODE=$G(^TMP($J,"FH",DATE,FHDFN,NUMBER,"RMTF")) Q:'NODE
+ ... S TF=$O(^TMP($J,"FH",DATE,FHDFN,NUMBER,"RMTF",TF)) Q:'TF  D
+ .... S TFNODE=^TMP($J,"FH",DATE,FHDFN,NUMBER,"RMTF",TF)
+ .... S PRODUCT=$P(TFNODE,U,1),ECXQTY=$P(TFNODE,U,4)
+ .... ;Resolve external value for product key
+ .... S ECXKEY=$$NUTKEY^ECXUTL6("TF",PRODUCT)
+ .... I $$NUTLOC^ECXUTL6(P,D,.ECXFPD,.ECXFDD,.ECXFPF,.ECXDLT,.ECXDFL)
+ .... ;Get additional data and file record.
+ .... D GET^ECXNUT
+ ;Get outpatient special meals
+ S (FHDFN,DATE)=0,(ECXADM,NODE,ECXORDPH)=""
+ S P="OP",D="SM" F  S DATE=$O(^TMP($J,"FH",DATE)) Q:'DATE  D
+ . F  S FHDFN=$O(^TMP($J,"FH",DATE,FHDFN)) Q:'FHDFN  D
+ .. S NODE=$G(^TMP($J,"FH",DATE,FHDFN,"SM")) Q:'NODE
+ .. S PRODUCT=$P(NODE,U,13),ECXQTY=1,ECXORDPH=$P(NODE,U,5)
+ .. ;Resolve external value for product key
+ .. S ECXKEY=$$NUTKEY^ECXUTL6("SM",PRODUCT)
+ .. I $$NUTLOC^ECXUTL6(P,D,.ECXFPD,.ECXFDD,.ECXFPF,.ECXDLT,.ECXDFL)
+ .. ;Get additional data and file record.
+ .. D GET^ECXNUT
+ ;Get outpatient guest meals
+ S (FHDFN,DATE)=0,(ECXADM,NODE,ECXORDPH)=""
+ S P="OP",D="GM" F  S DATE=$O(^TMP($J,"FH",DATE)) Q:'DATE  D
+ . F  S FHDFN=$O(^TMP($J,"FH",DATE,FHDFN)) Q:'FHDFN  D
+ .. S NODE=$G(^TMP($J,"FH",DATE,FHDFN,"GM")) Q:'NODE
+ .. S PRODUCT=$P(NODE,U,13),ECXQTY=1
+ .. ;Resolve external value for product key
+ .. S ECXKEY=$$NUTKEY^ECXUTL6("GM",PRODUCT)
+ .. I $$NUTLOC^ECXUTL6(P,D,.ECXFPD,.ECXFDD,.ECXFPF,.ECXDLT,.ECXDFL)
+ .. ;Get additional data and file record.
+ .. D GET^ECXNUT
+ Q

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXOPRX.m

@@ -1 @@
-ECXOPRX ;ALB/JAP,BIR/DMA,CML,PTD-Prescription Extract for DSS ; 11/5/07 8:17am
-        ;;3.0;DSS EXTRACTS;**10,11,8,13,24,30,33,38,39,46,49,71,81,84,92,105**;Dec 22, 1997;Build 70
-        ;
-BEG     ;entry point from option
-        D SETUP I ECFILE="" Q
-        D ^ECXTRAC,^ECXKILL
-        Q
-        ;
-START   ;entry when queued
-        N X,DA,DIC,DIQ,DR,ECXNPRFI,ECRXPTST,ECNONVAP,ECRXNUM,ECXSCRX
-        S QFLG=0
-        I '$D(ECINST) D
-        .S ECINST=+$P(^ECX(728,1,0),U) K ECXDIC S DA=ECINST,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99"
-        .D EN^DIQ1 S ECINST=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC
-        ;before V6
-        S ECPROF=6,ECD=$O(^PSRX("AL",0)) I ECD,ECD<ECSD1 G V6
-        S ECED=ECED+.3,ECREF=1,ECD=ECSD1
-        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
-        Q
-        ;
-V6      ;version 6 or better
-        K ^TMP($J,"ECXP")
-        S ECPROF=2,ECED=ECED+.3,ECREF=1,ECD=ECSD1
-        F  S ECD=$O(^PSRX("AL",ECD)),ECRX=0 Q:'ECD  Q:ECD>ECED  Q:QFLG  F  S ECRX=$O(^PSRX("AL",ECD,ECRX)),ECRFL="" Q:'ECRX  F  S ECRFL=$O(^PSRX("AL",ECD,ECRX,ECRFL)) Q:ECRFL=""  D STUFF Q:QFLG
-        Q:QFLG
-        S ECREF="P",ECD=ECSD1
-        F  S ECD=$O(^PSRX("AM",ECD)),ECRX=0 Q:'ECD  Q:ECD>ECED  Q:QFLG  F  S ECRX=$O(^PSRX("AM",ECD,ECRX)),ECRFL="" Q:'ECRX  F  S ECRFL=$O(^PSRX("AM",ECD,ECRX,ECRFL)) Q:ECRFL=""  D STUFF Q:QFLG
-        K ^TMP($J,"ECXP")
-        Q
-        ;
-STUFF   ;get data
-        N ECXPHA
-        S ECDATA=$G(^PSRX(ECRX,0)),ECXPHA=""
-        I ECRFL S ECDATA1=$G(^PSRX(ECRX,ECREF,ECRFL,0)) I ECDATA1="" Q
-        ;ecref set to 1 in extract+5 and v6+1 and to "P" in v6+2
-        ;refill nodes and partial nodes are identical in layout.  Fills
-        ;(ie ecrfl=0)& refills (ie ecrfl>0) from "AL" xref, partials from "AM"
-        S (ECXDSSD,ECXPROVN,ECXCVE,ECXCVEDT,ECXCVENC,ECRXPTST,ECRXNUM)="",ECXERR=0,ECXDATE=ECD,ECXDFN=$P(ECDATA,U,2),ECDRG=+$P(ECDATA,U,6)
-        ;- Get rx patient status & rx number
-        S ECRXPTST=$$RXPTST^ECXUTL5($P(ECDATA,U,3)),ECRXNUM=$P(ECDATA,U,1)
-        ;- Get provider (either 2_provider or 6_provider depending on version)
-        S ECXPROV=$S($P(ECDATA,U,4)'="":ECPROF_$P(ECDATA,U,4),1:""),ECXPROVP=$$PRVCLASS^ECXUTL($P(ECDATA,U,4),ECXDATE)
-        S ECPRVNPI=$$NPI^XUSNPI("Individual_ID",$P(ECDATA,U,4),ECXDATE)
-        S:+ECPRVNPI'>0 ECPRVNPI="" S ECPRVNPI=$P(ECPRVNPI,U)
-        ;get classification data
-        S ECXCLS=$G(^PSRX(ECRX,"IBQ")),ECXMIL=$P(ECXCLS,U,2),ECXAO=$P(ECXCLS,U,3),ECXIR=$P(ECXCLS,U,4),ECXECE=$P(ECXCLS,U,5),ECXHNC=$P(ECXCLS,U,6)
-        F X="ECXMIL","ECXAO","ECXIR","ECXECE","ECXHNC" S @X=$S(@X:"Y",@X=0:"N",1:"")
-        ;- Check non-va provider flag and set to 'Y' if exist
-        S ECNONVAP=$$NONVAP^ECXUTL5($E(ECXPROV,2,99))
-        ;get patient specific data
-        D PAT(ECXDFN,ECXDATE,.ECXERR) Q:ECXERR
-        I 'ECRFL D
-        .S ECMW=$P(ECDATA,U,11),ECQTY=+$P(ECDATA,U,7),ECXDIV=$S($D(^PSRX(ECRX,2)):$P(^(2),U,9),1:1)
-        .S ECPRC=+$P(ECDATA,U,17),ECOPAY=$P($G(^PSRX(ECRX,"IB")),U,2)]""
-        I ECRFL D
-        .S ECMW=$P(ECDATA1,U,2),ECQTY=+$P(ECDATA1,U,4),ECXDIV=$S(+$P(ECDATA1,U,9):$P(ECDATA1,U,9),1:1)
-        .S ECPRC=+$P(ECDATA1,U,11),ECOPAY=$P($G(^PSRX(ECRX,1,ECRFL,"IB")),U)]""
-        S ECXCOST=$J((ECQTY*ECPRC),1,2),ECDS=$S(ECRFL:$P(ECDATA1,U,10),1:$P(ECDATA,U,8))
-        ;call pharmacy drug file (#50) api
-        S ECXPHA=$$PHAAPI^ECXUTL5(ECDRG),ECCAT=$P(ECXPHA,U,2),ECINV=$P(ECXPHA,U,4)["I",ECINV=$S(ECINV:"I",1:""),ECUI=$P(ECXPHA,U,8),ECNDC=$P(ECXPHA,U,3)
-        S ECNFC=$$RJ^XLFSTR($P(ECNDC,"-"),6,0)_$$RJ^XLFSTR($P(ECNDC,"-",2),4,0)_$$RJ^XLFSTR($P(ECNDC,"-",3),2,0),ECNFC=$TR(ECNFC,"*",0),P1=$P(ECXPHA,U,5),P3=$P(ECXPHA,U,6)
-        S X="PSNAPIS" X ^%ZOSF("TEST") I $T S ECNFC=$$DSS^PSNAPIS(P1,P3,ECXYM)_ECNFC
-        I $L(ECNFC)=12 S ECNFC=$$RJ^XLFSTR(P1,4,0)_$$RJ^XLFSTR(P3,3,0)_ECNFC
-        I ECMW="M" S ECMW=1 I $D(^PSRX("AR",ECD,ECRX)) S ECMW=2
-        I ECMW="W" S ECMW=""
-        S ECXNEW="" I ECRFL=0 S ECXNEW=1
-        S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS) ;Observation pat indic (YES/NO)
-        S ECXORDPH="" ;Ordering physician (null for FY2002)
-        ;- Ordering stop code & Ordering date
-        S ECXORDST=$P($G(^ECX(728.44,+$P(ECDATA,U,5),0)),U,2),ECXORDDT=$$ECXDATE^ECXUTL(+$P(ECDATA,U,13),ECXYM)
-        S ECXCNH=$$CNHSTAT^ECXUTL4(ECXDFN) ;CNH status (YES/NO)
-        ;- DSS Dept and National Prod Division
-        ;S ECXDSSD=$$PRE^ECXDEPT(ECXDIV,ECMW,ECINST) dss department postponed
-        N ECXPDIV S ECXPDIV=$$PREDIV^ECXDEPT(ECXDIV)
-        ;- Set national patient record flag if exist
-        D NPRF^ECXUTL5
-        S ECXSCRX=$$SCRX^ECXUTL5(ECRX) ;Service connected rx
-        ;- If no encounter number don't file record
-        S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,,)
-        I ECXLOGIC>2003 D
-        .I (ECMW=2)!((ECMW=1)&(ECXLOGIC>2006)),ECXSSN'="" D
-        ..N TMP S TMP=$$JULDT^ECXUTL4(ECD),ECXENC=$E(ECXSSN,1,9)_TMP_"160",ECXA="O"
-        I ECXENC'="" D FILE^ECXOPRX1
-        Q
-        ;
-PAT(ECXDFN,ECXDATE,ECXERR)      ;Determine in/outpatient status, movement number, primary care team and provider
-        N OK,X,PT
-        S (ECXCAT,ECXSTAT,ECXPRIOR,ECXSBGRP,ECXOEF,ECXOEFDT)=""
-        ;get patient data if saved
-        I $D(^TMP($J,"ECXP",ECXDFN)) D
-        .S PT=^TMP($J,"ECXP",ECXDFN),ECXSSN=$P(PT,U),ECXPNM=$P(PT,U,2),ECXMPI=$P(PT,U,3),ECXSEX=$P(PT,U,4),ECXDOB=$P(PT,U,5)
-        .S ECXELIG=$P(PT,U,6),ECXVET=$P(PT,U,7),ECXRACE=$P(PT,U,8),ECXPST=$P(PT,U,9),ECXPLOC=$P(PT,U,10),ECXRST=$P(PT,U,11)
-        .S ECXAST=$P(PT,U,12),ECXMST=$P(PT,U,13),ECXSTATE=$P(PT,U,14),ECXCNTY=$P(PT,U,15),ECXZIP=$P(PT,U,16),ECXENRL=$P(PT,U,17)
-        .S ECXPHI=$P(PT,U,20),ECXCAT=$P(PT,U,21),ECXSTAT=$P(PT,U,22),ECXPRIOR=$P(PT,U,23)
-        .S ECXCNHU=$P(PT,U,24),ECXPOS=$P(PT,U,25),ECXAOL=$P(PT,U,26),ECXHNCI=$P(PT,U,27),ECXETH=$P(PT,U,28),ECXRC1=$P(PT,U,29),ECXMTST=$P(PT,U,30)
-        .S PT1=$G(^TMP($J,"ECXP",ECXDFN,1)),ECXERI=$P(PT1,U),ECXEST=$P(PT1,U,2),ECXOEF=$P(PT1,U,3),ECXOEFDT=$P(PT1,U,4)
-        .I $$ENROLLM^ECXUTL2(ECXDFN)
-        ;set patient data
-        I '$D(^TMP($J,"ECXP",ECXDFN)) D  Q:'OK
-        .K ECXPAT
-        .S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECSD1,"."),"1;2;3;5",.ECXPAT)
-        .I 'OK S ECXERR=1 Q
-        .S ECXSSN=ECXPAT("SSN"),ECXPNM=ECXPAT("NAME"),ECXMPI=ECXPAT("MPI"),ECXSEX=ECXPAT("SEX"),ECXDOB=ECXPAT("DOB"),ECXELIG=ECXPAT("ELIG")
-        .S ECXVET=ECXPAT("VET"),ECXRACE=ECXPAT("RACE"),ECXPST=ECXPAT("POW STAT"),ECXPLOC=ECXPAT("POW LOC"),ECXRST=ECXPAT("IR STAT")
-        .S ECXAST=ECXPAT("AO STAT"),ECXMST=ECXPAT("MST STAT"),ECXSTATE=ECXPAT("STATE"),ECXCNTY=ECXPAT("COUNTY"),ECXZIP=ECXPAT("ZIP"),ECXENRL=ECXPAT("ENROLL LOC")
-        .S ECXERI=ECXPAT("ERI"),ECXEST=ECXPAT("EC STAT")
-        .;- CNH Stat (placeholder),Purp Heart Ind,Per of Svce,AO Loc,MT Stat
-        .S ECXCNHU="",ECXPHI=ECXPAT("PHI"),ECXPOS=ECXPAT("POS"),ECXAOL=ECXPAT("AOL"),ECXMTST=ECXPAT("MEANS")
-        .I $$ENROLLM^ECXUTL2(ECXDFN)
-        .S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) ;Head and Neck Cancer Indicator
-        .S ECXETH=ECXPAT("ETHNIC"),ECXRC1=ECXPAT("RACE1") ;Race and Ethnicity
-        .; OEF/OIF data
-        .S ECXOEF=ECXPAT("ECXOEF")
-        .S ECXOEFDT=ECXPAT("ECXOEFDT")
-        .S ^TMP($J,"ECXP",ECXDFN)=ECXSSN_U_ECXPNM_U_ECXMPI_U_ECXSEX_U_ECXDOB_U_ECXELIG_U_ECXVET_U_ECXRACE_U_ECXPST_U_ECXPLOC_U_ECXRST_U_ECXAST_U_ECXMST_U_ECXSTATE_U_ECXCNTY_U_ECXZIP_U_ECXENRL_U_U
-        .S ^TMP($J,"ECXP",ECXDFN)=^TMP($J,"ECXP",ECXDFN)_U_ECXPHI_U_ECXCAT_U_ECXSTAT_U_ECXPRIOR_U_ECXCNHU_U_ECXPOS_U_ECXAOL_U_ECXHNCI_U_ECXETH_U_ECXRC1_U_ECXMTST
-        .S ^TMP($J,"ECXP",ECXDFN,1)=ECXERI_U_ECXEST_U_ECXOEF_U_ECXOEFDT
-        ;get inpatient data
-        S (ECXA,ECXADMDT,ECXDOM,ECXMN,ECXTS)="",X=$$INP^ECXUTL2(ECXDFN,ECXDATE) D
-        .S ECXA=$P(X,U),ECXMN=$P(X,U,2),ECXTS=$P(X,U,3),ECXDOM=$P(X,U,10),ECXADMDT=$P(X,U,4)
-        ;get primary care data
-        S X=$$PRIMARY^ECXUTL2(ECXDFN,$P(ECXDATE,".")),ECPTTM=$P(X,U),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4),ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7)
-        Q
-        ;
-SETUP   ;Set required input for ECXTRAC
-        S ECHEAD="PRE"
-        D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
-        Q
-QUE     ; entry point for the background requeuing handled by ECXTAUTO
-        D SETUP,QUE^ECXTAUTO,^ECXKILL Q
+ECXOPRX ;ALB/JAP,BIR/DMA,CML,PTD-Prescription Extract for DSS ; 11/2/06 8:42am
+ ;;3.0;DSS EXTRACTS;**10,11,8,13,24,30,33,38,39,46,49,71,81,84,92**;Dec 22, 1997;Build 30
+ ;
+BEG ;entry point from option
+ D SETUP I ECFILE="" Q
+ D ^ECXTRAC,^ECXKILL
+ Q
+ ;
+START ;entry when queued
+ N X,DA,DIC,DIQ,DR,ECXNPRFI,ECRXPTST,ECNONVAP,ECRXNUM,ECXSCRX
+ S QFLG=0
+ I '$D(ECINST) D
+ .S ECINST=+$P(^ECX(728,1,0),U) K ECXDIC S DA=ECINST,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99"
+ .D EN^DIQ1 S ECINST=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC
+ ;before V6
+ S ECPROF=6,ECD=$O(^PSRX("AL",0)) I ECD,ECD<ECSD1 G V6
+ S ECED=ECED+.3,ECREF=1,ECD=ECSD1
+ 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
+ Q
+ ;
+V6 ;version 6 or better
+ K ^TMP($J,"ECXP")
+ S ECPROF=2,ECED=ECED+.3,ECREF=1,ECD=ECSD1
+ F  S ECD=$O(^PSRX("AL",ECD)),ECRX=0 Q:'ECD  Q:ECD>ECED  Q:QFLG  F  S ECRX=$O(^PSRX("AL",ECD,ECRX)),ECRFL="" Q:'ECRX  F  S ECRFL=$O(^PSRX("AL",ECD,ECRX,ECRFL)) Q:ECRFL=""  D STUFF Q:QFLG
+ Q:QFLG
+ S ECREF="P",ECD=ECSD1
+ F  S ECD=$O(^PSRX("AM",ECD)),ECRX=0 Q:'ECD  Q:ECD>ECED  Q:QFLG  F  S ECRX=$O(^PSRX("AM",ECD,ECRX)),ECRFL="" Q:'ECRX  F  S ECRFL=$O(^PSRX("AM",ECD,ECRX,ECRFL)) Q:ECRFL=""  D STUFF Q:QFLG
+ K ^TMP($J,"ECXP")
+ Q
+ ;
+STUFF ;get data
+ N ECXPHA
+ S ECDATA=$G(^PSRX(ECRX,0)),ECXPHA=""
+ I ECRFL S ECDATA1=$G(^PSRX(ECRX,ECREF,ECRFL,0)) I ECDATA1="" Q
+ ;ecref set to 1 in extract+5 and v6+1 and to "P" in v6+2
+ ;refill nodes and partial nodes are identical in layout.  Fills
+ ;(ie ecrfl=0)& refills (ie ecrfl>0) from "AL" xref, partials from "AM"
+ S (ECXDSSD,ECXPROVN,ECXCVE,ECXCVEDT,ECXCVENC,ECRXPTST,ECRXNUM)="",ECXERR=0,ECXDATE=ECD,ECXDFN=$P(ECDATA,U,2),ECDRG=+$P(ECDATA,U,6)
+ ;- Get rx patient status & rx number
+ S ECRXPTST=$$RXPTST^ECXUTL5($P(ECDATA,U,3)),ECRXNUM=$P(ECDATA,U,1)
+ ;- Get provider (either 2_provider or 6_provider depending on version)
+ S ECXPROV=$S($P(ECDATA,U,4)'="":ECPROF_$P(ECDATA,U,4),1:""),ECXPROVP=$$PRVCLASS^ECXUTL($P(ECDATA,U,4),ECXDATE)
+ ;get classification data
+ S ECXCLS=$G(^PSRX(ECRX,"IBQ")),ECXMIL=$P(ECXCLS,U,2),ECXAO=$P(ECXCLS,U,3),ECXIR=$P(ECXCLS,U,4),ECXECE=$P(ECXCLS,U,5),ECXHNC=$P(ECXCLS,U,6)
+ F X="ECXMIL","ECXAO","ECXIR","ECXECE","ECXHNC" S @X=$S(@X:"Y",@X=0:"N",1:"")
+ ;- Check non-va provider flag and set to 'Y' if exist
+ S ECNONVAP=$$NONVAP^ECXUTL5($E(ECXPROV,2,99))
+ ;get patient specific data
+ D PAT(ECXDFN,ECXDATE,.ECXERR) Q:ECXERR
+ I 'ECRFL D
+ .S ECMW=$P(ECDATA,U,11),ECQTY=+$P(ECDATA,U,7),ECXDIV=$S($D(^PSRX(ECRX,2)):$P(^(2),U,9),1:1)
+ .S ECPRC=+$P(ECDATA,U,17),ECOPAY=$P($G(^PSRX(ECRX,"IB")),U,2)]""
+ I ECRFL D
+ .S ECMW=$P(ECDATA1,U,2),ECQTY=+$P(ECDATA1,U,4),ECXDIV=$S(+$P(ECDATA1,U,9):$P(ECDATA1,U,9),1:1)
+ .S ECPRC=+$P(ECDATA1,U,11),ECOPAY=$P($G(^PSRX(ECRX,1,ECRFL,"IB")),U)]""
+ S ECXCOST=$J((ECQTY*ECPRC),1,2),ECDS=$S(ECRFL:$P(ECDATA1,U,10),1:$P(ECDATA,U,8))
+ ;call pharmacy drug file (#50) api
+ S ECXPHA=$$PHAAPI^ECXUTL5(ECDRG),ECCAT=$P(ECXPHA,U,2),ECINV=$P(ECXPHA,U,4)["I",ECINV=$S(ECINV:"I",1:""),ECUI=$P(ECXPHA,U,8),ECNDC=$P(ECXPHA,U,3)
+ S ECNFC=$$RJ^XLFSTR($P(ECNDC,"-"),6,0)_$$RJ^XLFSTR($P(ECNDC,"-",2),4,0)_$$RJ^XLFSTR($P(ECNDC,"-",3),2,0),ECNFC=$TR(ECNFC,"*",0),P1=$P(ECXPHA,U,5),P3=$P(ECXPHA,U,6)
+ S X="PSNAPIS" X ^%ZOSF("TEST") I $T S ECNFC=$$DSS^PSNAPIS(P1,P3,ECXYM)_ECNFC
+ I $L(ECNFC)=12 S ECNFC=$$RJ^XLFSTR(P1,4,0)_$$RJ^XLFSTR(P3,3,0)_ECNFC
+ I ECMW="M" S ECMW=1 I $D(^PSRX("AR",ECD,ECRX)) S ECMW=2
+ I ECMW="W" S ECMW=""
+ S ECXNEW="" I ECRFL=0 S ECXNEW=1
+ S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS) ;Observation pat indic (YES/NO)
+ S ECXORDPH="" ;Ordering physician (null for FY2002)
+ ;- Ordering stop code & Ordering date
+ S ECXORDST=$P($G(^ECX(728.44,+$P(ECDATA,U,5),0)),U,2),ECXORDDT=$$ECXDATE^ECXUTL(+$P(ECDATA,U,13),ECXYM)
+ S ECXCNH=$$CNHSTAT^ECXUTL4(ECXDFN) ;CNH status (YES/NO)
+ ;- DSS Dept and National Prod Division
+ ;S ECXDSSD=$$PRE^ECXDEPT(ECXDIV,ECMW,ECINST) dss department postponed
+ N ECXPDIV S ECXPDIV=$$PREDIV^ECXDEPT(ECXDIV)
+ ;- Set national patient record flag if exist
+ D NPRF^ECXUTL5
+ S ECXSCRX=$$SCRX^ECXUTL5(ECRX) ;Service connected rx
+ ;- If no encounter number don't file record
+ S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,,)
+ I ECXLOGIC>2003 D
+ .I (ECMW=2)!((ECMW=1)&(ECXLOGIC>2006)),ECXSSN'="" D
+ ..N TMP S TMP=$$JULDT^ECXUTL4(ECD),ECXENC=$E(ECXSSN,1,9)_TMP_"160",ECXA="O"
+ I ECXENC'="" D FILE^ECXOPRX1
+ Q
+ ;
+PAT(ECXDFN,ECXDATE,ECXERR) ;Determine in/outpatient status, movement number, primary care team and provider
+ N OK,X,PT
+ S (ECXCAT,ECXSTAT,ECXPRIOR,ECXSBGRP)=""
+ ;get patient data if saved
+ I $D(^TMP($J,"ECXP",ECXDFN)) D
+ .S PT=^TMP($J,"ECXP",ECXDFN),ECXSSN=$P(PT,U),ECXPNM=$P(PT,U,2),ECXMPI=$P(PT,U,3),ECXSEX=$P(PT,U,4),ECXDOB=$P(PT,U,5)
+ .S ECXELIG=$P(PT,U,6),ECXVET=$P(PT,U,7),ECXRACE=$P(PT,U,8),ECXPST=$P(PT,U,9),ECXPLOC=$P(PT,U,10),ECXRST=$P(PT,U,11)
+ .S ECXAST=$P(PT,U,12),ECXMST=$P(PT,U,13),ECXSTATE=$P(PT,U,14),ECXCNTY=$P(PT,U,15),ECXZIP=$P(PT,U,16),ECXENRL=$P(PT,U,17)
+ .S ECXPHI=$P(PT,U,20),ECXCAT=$P(PT,U,21),ECXSTAT=$P(PT,U,22),ECXPRIOR=$P(PT,U,23)
+ .S ECXCNHU=$P(PT,U,24),ECXPOS=$P(PT,U,25),ECXAOL=$P(PT,U,26),ECXHNCI=$P(PT,U,27),ECXETH=$P(PT,U,28),ECXRC1=$P(PT,U,29),ECXMTST=$P(PT,U,30)
+ .S PT1=$G(^TMP($J,"ECXP",ECXDFN,1)),ECXERI=$P(PT1,U),ECXEST=$P(PT1,U,2)
+ .I $$ENROLLM^ECXUTL2(ECXDFN)
+ ;set patient data
+ I '$D(^TMP($J,"ECXP",ECXDFN)) D  Q:'OK
+ .K ECXPAT
+ .S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECSD1,"."),"1;2;3;5",.ECXPAT)
+ .I 'OK S ECXERR=1 Q
+ .S ECXSSN=ECXPAT("SSN"),ECXPNM=ECXPAT("NAME"),ECXMPI=ECXPAT("MPI"),ECXSEX=ECXPAT("SEX"),ECXDOB=ECXPAT("DOB"),ECXELIG=ECXPAT("ELIG")
+ .S ECXVET=ECXPAT("VET"),ECXRACE=ECXPAT("RACE"),ECXPST=ECXPAT("POW STAT"),ECXPLOC=ECXPAT("POW LOC"),ECXRST=ECXPAT("IR STAT")
+ .S ECXAST=ECXPAT("AO STAT"),ECXMST=ECXPAT("MST STAT"),ECXSTATE=ECXPAT("STATE"),ECXCNTY=ECXPAT("COUNTY"),ECXZIP=ECXPAT("ZIP"),ECXENRL=ECXPAT("ENROLL LOC")
+ .S ECXERI=ECXPAT("ERI"),ECXEST=ECXPAT("EC STAT")
+ .;- CNH Stat (placeholder),Purp Heart Ind,Per of Svce,AO Loc,MT Stat
+ .S ECXCNHU="",ECXPHI=ECXPAT("PHI"),ECXPOS=ECXPAT("POS"),ECXAOL=ECXPAT("AOL"),ECXMTST=ECXPAT("MEANS")
+ .I $$ENROLLM^ECXUTL2(ECXDFN)
+ .S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) ;Head and Neck Cancer Indicator
+ .S ECXETH=ECXPAT("ETHNIC"),ECXRC1=ECXPAT("RACE1") ;Race and Ethnicity
+ .S ^TMP($J,"ECXP",ECXDFN)=ECXSSN_U_ECXPNM_U_ECXMPI_U_ECXSEX_U_ECXDOB_U_ECXELIG_U_ECXVET_U_ECXRACE_U_ECXPST_U_ECXPLOC_U_ECXRST_U_ECXAST_U_ECXMST_U_ECXSTATE_U_ECXCNTY_U_ECXZIP_U_ECXENRL_U_U
+ .S ^TMP($J,"ECXP",ECXDFN)=^TMP($J,"ECXP",ECXDFN)_U_ECXPHI_U_ECXCAT_U_ECXSTAT_U_ECXPRIOR_U_ECXCNHU_U_ECXPOS_U_ECXAOL_U_ECXHNCI_U_ECXETH_U_ECXRC1_U_ECXMTST
+ .S ^TMP($J,"ECXP",ECXDFN,1)=ECXERI_U_ECXEST
+ ;get inpatient data
+ S (ECXA,ECXADMDT,ECXDOM,ECXMN,ECXTS)="",X=$$INP^ECXUTL2(ECXDFN,ECXDATE) D
+ .S ECXA=$P(X,U),ECXMN=$P(X,U,2),ECXTS=$P(X,U,3),ECXDOM=$P(X,U,10),ECXADMDT=$P(X,U,4)
+ ;get primary care data
+ S X=$$PRIMARY^ECXUTL2(ECXDFN,$P(ECXDATE,".")),ECPTTM=$P(X,U),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4),ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7)
+ Q
+ ;
+SETUP ;Set required input for ECXTRAC
+ S ECHEAD="PRE"
+ D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
+ Q
+QUE ; entry point for the background requeuing handled by ECXTAUTO
+ D SETUP,QUE^ECXTAUTO,^ECXKILL Q

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXOPRX1.m

@@ -1 @@
-ECXOPRX1        ;ALB/JAP,BIR/DMA,CML,PTD-Prescription Extract for DSS ; 6/6/07 7:23am
-        ;;3.0;DSS EXTRACTS;**92,107,105**;Dec 22, 1997;Build 70
-        ;
-FILE    ;file record
-        ;node0
-        ;inst^dfn^ssn^name^in/out ECXA^day^division^provider^drug category^mail^
-        ;placeholder1^new^placeholder2^qty^cost^placeholder3^mov #^treat spec^placeholder4^unit of issue^dob^elig^vet^copay^
-        ;feeder key^investigational^days supply^primary care team^primary care provider^time^race
-        ;node1
-        ;mpi^dss dept ECXDSSD^sex^zip+4^placeholder^placeholder^state^county^pc prov person class^pow status^pow location^
-        ;ir status^ao status^sharing agree. payor^sharing agree. ins.^mst status^enroll loc^assoc pc provider^assoc pc prov person class^
-        ;placeholder^dom ECXDOM^purple heart ECXPHI^enrollment category ECXCAT^enrollment status ECXSTST^
-        ;enrollment priority ECXPRIOR^cnhu status ECXCNHU^period of service ECXPOS^observ pat ind ECXOBS^encounter num ECXENC^
-        ;ao loc ECXAOL^ord physician ECXORDPH^ord stop code ECXORDST^ord date ECXORDDT^CNH status ECXCNH^national division ECXPDIV^
-        ;MT Stat ECXMTST^head & neck cancer ind. ECXHNCI^ethnicity ECXETH^race ECXRC1^^enrollment priority ECXPRIOR_
-        ;enrollment subgroup ECXSBGRP^user enrollee ECXUESTA^patient type ECXPTYPE^combat vet elig ECXCVE^combat vet elig end date ECXCVEDT^
-        ;enc cv eligible ECXCVENC^national patient record flag ECXNPRFI^rx patient status ECRXPTST^non-va prescriber ECNONVAP^rx # ECRXNUM
-        ;^emergency response indicator(FEMA) ECXERI^agent orange enc ECXAO^environ cont PGE ECXECE^head/neck ECXHNC^enc mst ECXMIL^environ contamin ECXEST^ion radiat ECXIR
-        ;OEF/OIF data ECXOEF^OEFOIF return date ECXOEFDT^associate pc provider npi ECASNPI^primary care provider npi ECPTNPI^provider npi ECPRVNPI
-        N DA,DIK
-        S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1
-        S ECODE=EC7_U_EC23_U_ECINST_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U
-        S ECODE=ECODE_$$ECXDATE^ECXUTL(ECXDATE,ECXYM)_U_ECXDIV_U
-        S ECODE=ECODE_ECXPROV_U_ECCAT_U_ECMW_U_ECXPROVP_U_ECXNEW_U_U_ECQTY_U
-        ;convert specialty to PTF Code for transmission
-        N ECXDATA
-        S ECXDATA=$$TSDATA^DGACT(42.4,+ECXTS,.ECXDATA)
-        S ECXTS=$G(ECXDATA(7))
-        ;done
-        S ECODE=ECODE_ECXCOST_U_U_ECXMN_U_ECXTS_U_U_ECUI_U_ECXDOB_U
-        S ECODE=ECODE_ECXELIG_U_ECXVET_U_ECOPAY_U_ECNFC_U_ECINV_U_ECDS_U
-        S ECODE=ECODE_ECPTTM_U_ECPTPR_U_$$ECXTIME^ECXUTL(ECXDATE)_U_ECXRACE_U
-        S ECODE1=ECXMPI_U_ECXDSSD_U_ECXSEX_U_ECXZIP_U_ECXPROVN_U_U
-        S ECODE1=ECODE1_ECXSTATE_U_ECXCNTY_U_ECCLAS_U_ECXPST_U_ECXPLOC_U
-        S ECODE1=ECODE1_ECXRST_U_ECXAST_U_U_U_ECXMST_U_ECXENRL_U
-        S ECODE1=ECODE1_ECASPR_U_ECCLAS2_U_U_ECXDOM_U_ECXPHI_U_ECXCAT_U
-        S ECODE1=ECODE1_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXCNHU_U_ECXPOS_U_ECXOBS_U
-        S ECODE1=ECODE1_ECXENC_U_ECXAOL_U_ECXORDPH_U_ECXORDST_U_ECXORDDT_U
-        S ECODE1=ECODE1_ECXCNH_U_ECXPDIV_U_ECXMTST_U_ECXHNCI_U_ECXETH_U
-        S ECODE1=ECODE1_ECXRC1_U
-        I ECXLOGIC>2004 S ECODE1=ECODE1_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U
-        I ECXLOGIC>2004 S ECODE2=ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXNPRFI_U_ECRXPTST_U_ECNONVAP
-        I ECXLOGIC>2005 S ECODE2=ECODE2_U_ECRXNUM
-        I ECXLOGIC>2006 S ECODE2=ECODE2_U_ECXERI_U_ECXAO_U_ECXECE_U_ECXHNC_U_ECXMIL_U_ECXEST_U_ECXIR_U_ECXSCRX
-        I ECXLOGIC>2007 S ECODE2=ECODE2_U_ECXOEF_U_ECXOEFDT_U_ECASNPI_U_ECPTNPI_U_ECPRVNPI
-        S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,^ECX(ECFILE,EC7,2)=$G(ECODE2),ECRN=ECRN+1
-        S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA
-        I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1
-        Q
+ECXOPRX1 ;ALB/JAP,BIR/DMA,CML,PTD-Prescription Extract for DSS ; 4/19/2007
+ ;;3.0;DSS EXTRACTS;**92,107**;Dec 22, 1997;Build 9
+ ;
+FILE ;file record
+ ;node0
+ ;inst^dfn^ssn^name^in/out ECXA^day^division^provider^drug category^mail^
+ ;placeholder1^new^placeholder2^qty^cost^placeholder3^mov #^treat spec^placeholder4^unit of issue^dob^elig^vet^copay^
+ ;feeder key^investigational^days supply^primary care team^primary care provider^time^race
+ ;node1
+ ;mpi^dss dept ECXDSSD^sex^zip+4^provider npi^pc provider npi^state^county^pc prov person class^pow status^pow location^
+ ;ir status^ao status^sharing agree. payor^sharing agree. ins.^mst status^enroll loc^assoc pc provider^assoc pc prov person class^
+ ;assoc pc prov npi^dom ECXDOM^purple heart ECXPHI^enrollment category ECXCAT^enrollment status ECXSTST^
+ ;enrollment priority ECXPRIOR^cnhu status ECXCNHU^period of service ECXPOS^observ pat ind ECXOBS^encounter num ECXENC^
+ ;ao loc ECXAOL^ord physician ECXORDPH^ord stop code ECXORDST^ord date ECXORDDT^CNH status ECXCNH^national division ECXPDIV^
+ ;MT Stat ECXMTST^head & neck cancer ind. ECXHNCI^ethnicity ECXETH^race ECXRC1^^enrollment priority ECXPRIOR_
+ ;enrollment subgroup ECXSBGRP^user enrollee ECXUESTA^patient type ECXPTYPE^combat vet elig ECXCVE^combat vet elig end date ECXCVEDT^
+ ;enc cv eligible ECXCVENC^national patient record flag ECXNPRFI^rx patient status ECRXPTST^non-va prescriber ECNONVAP^rx # ECRXNUM
+ ;^emergency response indicator(FEMA) ECXERI^agent orange enc ECXAO^environ cont PGE ECXECE^head/neck ECXHNC^enc mst ECXMIL^environ contamin ECXEST^ion radiat ECXIR
+ N DA,DIK
+ S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1
+ S ECODE=EC7_U_EC23_U_ECINST_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U
+ S ECODE=ECODE_$$ECXDATE^ECXUTL(ECXDATE,ECXYM)_U_ECXDIV_U
+ S ECODE=ECODE_ECXPROV_U_ECCAT_U_ECMW_U_ECXPROVP_U_ECXNEW_U_U_ECQTY_U
+ ;convert specialty to PTF Code for transmission
+ N ECXDATA
+ S ECXDATA=$$TSDATA^DGACT(42.4,+ECXTS,.ECXDATA)
+ S ECXTS=$G(ECXDATA(7))
+ ;done
+ S ECODE=ECODE_ECXCOST_U_U_ECXMN_U_ECXTS_U_U_ECUI_U_ECXDOB_U
+ S ECODE=ECODE_ECXELIG_U_ECXVET_U_ECOPAY_U_ECNFC_U_ECINV_U_ECDS_U
+ S ECODE=ECODE_ECPTTM_U_ECPTPR_U_$$ECXTIME^ECXUTL(ECXDATE)_U_ECXRACE_U
+ S ECODE1=ECXMPI_U_ECXDSSD_U_ECXSEX_U_ECXZIP_U_ECXPROVN_U_ECPTNPI_U
+ S ECODE1=ECODE1_ECXSTATE_U_ECXCNTY_U_ECCLAS_U_ECXPST_U_ECXPLOC_U
+ S ECODE1=ECODE1_ECXRST_U_ECXAST_U_U_U_ECXMST_U_ECXENRL_U
+ S ECODE1=ECODE1_ECASPR_U_ECCLAS2_U_ECASNPI_U_ECXDOM_U_ECXPHI_U_ECXCAT_U
+ S ECODE1=ECODE1_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXCNHU_U_ECXPOS_U_ECXOBS_U
+ S ECODE1=ECODE1_ECXENC_U_ECXAOL_U_ECXORDPH_U_ECXORDST_U_ECXORDDT_U
+ S ECODE1=ECODE1_ECXCNH_U_ECXPDIV_U_ECXMTST_U_ECXHNCI_U_ECXETH_U
+ S ECODE1=ECODE1_ECXRC1_U
+ I ECXLOGIC>2004 S ECODE1=ECODE1_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U
+ I ECXLOGIC>2004 S ECODE2=ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXNPRFI_U_ECRXPTST_U_ECNONVAP
+ I ECXLOGIC>2005 S ECODE2=ECODE2_U_ECRXNUM
+ I ECXLOGIC>2006 S ECODE2=ECODE2_U_ECXERI_U_ECXAO_U_ECXECE_U_ECXHNC_U_ECXMIL_U_ECXEST_U_ECXIR_U_ECXSCRX
+ S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,^ECX(ECFILE,EC7,2)=$G(ECODE2),ECRN=ECRN+1
+ S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA
+ I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1
+ Q

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXPIVDN.m

@@ -1 @@
-ECXPIVDN        ;ALB/JAP,BIR/DMA,CML,PTD-Extract from IV EXTRACT DATA File (#728.113) ; 10/31/07 1:38pm
-        ;;3.0;DSS EXTRACTS;**10,11,8,13,24,33,39,46,49,71,84,96,92,107,105**;Dec 22, 1997;Build 70
-BEG     ;entry point from option
-        D SETUP I ECFILE="" Q
-        D ^ECXTRAC,^ECXKILL
-        Q
-        ;
-START   ; start package specific extract
-        N DIC,DA,DR,DIQ,DFN,ECXNPRFI,ECXPHA
-        S QFLG=0
-        I '$D(ECINST) D
-        .S ECINST=+$P(^ECX(728,1,0),U) K ECXDIC S DA=ECINST,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99"
-        .D EN^DIQ1 S ECINST=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC
-        S ECED=ECED+.3
-        K ^TMP($J,"A"),^TMP($J,"S")
-        S ECD=ECSD1
-        F  S ECD=$O(^ECX(728.113,"A",ECD)),DFN=0 Q:'ECD  Q:ECD>ECED  Q:QFLG  F  S DFN=$O(^ECX(728.113,"A",ECD,DFN)),ON=0  Q:'DFN  F  S ON=$O(^ECX(728.113,"A",ECD,DFN,ON)),DA=0 Q:'ON  K ^TMP($J,"A"),^TMP($J,"S") S ECVOL=0 D  Q:QFLG
-        .S ECXERR=0 D PAT(DFN,ECD,.ECXERR)
-        .Q:ECXERR
-        .F  S DA=$O(^ECX(728.113,"A",ECD,DFN,ON,DA)) Q:'DA  Q:QFLG  I $D(^ECX(728.113,DA,0)) S EC=^(0) D  Q:QFLG
-        ..S DRG=$P(EC,U,4) I $P(EC,U,8)]"" D
-        ...I '$D(^TMP($J,"A",DRG)) S ^(DRG)=$P(EC,U,7,8),^(DRG,1)=0,^(2)=$P(EC,U,12)
-        ...S ^(1)=^TMP($J,"A",DRG,1)+$S($P(EC,U,6)=1:1,$P(EC,U,6)=4:0,1:-1)
-        ..I $P(EC,U,9) D
-        ...I '$D(^TMP($J,"S",DRG)) S ^(DRG)=$P(EC,U,9)_"^ML",^(DRG,1)=0,^(2)=$P(EC,U,12),ECVOL=$P(EC,U,9)+ECVOL
-        ...S ^(1)=^TMP($J,"S",DRG,1)+$S($P(EC,U,6)=1:1,$P(EC,U,6)=4:0,1:-1)
-        ..S ECTYP=$P(EC,U,11),ECTOTC=0,ECDTTM=$$ECXTIME^ECXUTL($P(EC,U,5))
-        .;looped thru all DAs for this order - now put it together
-        .;leave the next line in case the decision is made to send volume designations
-        .;I ECTYP="H" S ECTYP=ECTYP_$S(ECVOL'>1000:1,ECVOL'>2000:2,1:3)
-        .S ECXDSSI=""
-        .;loop thru tmp global and call pharmacy drug file (#50) api
-        .F SA="S","A" S DRG="" F  S DRG=$O(^TMP($J,SA,DRG)) Q:DRG=""  S ECXPHA="",ECXPHA=$$PHAAPI^ECXUTL5(DRG) I $P(ECXPHA,U)'="" D STUFF Q:QFLG
-        K ^TMP($J),CLIN,DA,DFN,DIC,DIK,DRG,ON,SA,X,Y,P1,P3
-        Q
-STUFF   ;get data
-        N ECORDST
-        S ECST=^TMP($J,SA,DRG),ECXCNT=^(DRG,1),ECXCOST=^(2),ECXCOST=ECXCOST*ECXCNT,ECVACL=$P(ECXPHA,U,2),ECORDST=""
-        ;if outpatient get division from iv rm; get dss identifier for clinic
-        I ECXA="O" D
-        .;- Only set ward to .5 if outpatient (but NOT observation patient)
-        .I $G(ECXW)="" S ECXW=.5
-        .I $P(EC,U,15) S ECIVRM=$P(EC,U,15),ECXDIV=$$PSJ59P5^ECXUTL5(ECIVRM)
-        .S CLIN=+$P(EC,U,13),(ECXP1,ECXP2)="000",ECXCL=$G(^ECX(728.44,CLIN,0)) Q:ECXCL=""
-        .S ECSC=$P(ECXCL,U,4),ECCSC=$P(ECXCL,U,5)
-        .I ECSC="" S ECSC=$P(ECXCL,U,2),ECCSC=$P(ECXCL,U,3)
-        .I ECSC S ECXP1=$$RJ^XLFSTR(ECSC,3,0),ECXP2=$$RJ^XLFSTR(ECCSC,3,0)
-        .I ECSC="" S ECSC=$P($G(^SC(ECXCL,0)),U,7),ECCSC=$P($G(^SC(ECXCL,0)),U,18) I ECSC D
-        ..S ECXP1=$P($G(^DIC(40.7,ECSC,0)),U,2) S:ECCSC]"" ECXP2=$P($G(^DIC(40.7,ECCSC,0)),U,2)
-        ..S ECXP1=$$RJ^XLFSTR(ECXP1,3,0),ECXP2=$$RJ^XLFSTR(ECXP2,3,0)
-        .S ECXDSSI=ECXP1_ECXP2
-        .I ECXLOGIC>2003 D
-        ..I "^18^23^24^36^41^65^94^"[("^"_ECXTS_"^") S ECXDSSI=$$TSMAP^ECXUTL4(ECXTS)
-        S ECINV=$P(ECXPHA,U,4),ECINV=$S(ECINV["I":"I",1:""),ECST=ECXCNT*ECST_" "_$P(ECST,U,2)
-        S ECNDC=$P(ECXPHA,U,3),ECNFC=$$RJ^XLFSTR($P(ECNDC,"-"),6,0)_$$RJ^XLFSTR($P(ECNDC,"-",2),4,0)_$$RJ^XLFSTR($P(ECNDC,"-",3),2,0),ECNFC=$TR(ECNFC,"*",0)
-        S P1=$P(ECXPHA,U,5),P3=$P(ECXPHA,U,6)
-        S X="PSNAPIS" X ^%ZOSF("TEST") I $T S ECNFC=$$DSS^PSNAPIS(P1,P3,ECXYM)_ECNFC
-        I $L(ECNFC)=12 S ECNFC=$$RJ^XLFSTR(P1,4,0)_$$RJ^XLFSTR(P3,3,0)_ECNFC
-        ;- Ordering provider ("2"_provider)
-        S ECXORDPR=$S(+$P(EC,U,10):"2"_$P(EC,U,10),1:"")
-        N ECXUSRTN
-        S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",$P(EC,U,10),$P(EC,U,16))
-        S:+ECXUSRTN'>0 ECXUSRTN="" S ECXOPNPI=$P(ECXUSRTN,U)
-        S ECXORDDT=$P(EC,U,16) ;- Ordering date
-        ;- Requesting physician (null for FY2002)
-        S ECXRPHY=""
-        ;- Department and National Prod Division
-        S ECXDSSD="" ;dss department use postponed $$IVP^ECXDEPT(ECXDIV)
-        N ECXPDIV S ECXPDIV=$$GETDIV^ECXDEPT(ECXDIV)
-        ;- Observation patient indicator (yes/no)
-        S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXDSSI)
-        ; - Ordering Date, Ordering Stop Code
-        S ECXORDST="" I ECXA="O" D
-        .S ECXORDST=$$DOIVPO^ECXUTL5(DFN,ON)
-        .I ECXOBS="NO" S ECORDST="160"
-        .I ECXOBS="YES" S ECORDST=$P($G(^ECX(727.831,+ECXTS,0)),U,6)
-        ;- If no encounter number don't file record
-        S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADM,ECD,ECXTS,ECXOBS,ECHEAD,ECORDST,)
-        ;get BCMA data
-        S (ECXBCDD,ECXBCDG,ECXBCUA,ECXBCIF)=""
-        ;get ordering provider person class
-        S ECXOPPC=$$PRVCLASS^ECXUTL($E(ECXORDPR,2,999),ECXORDDT)
-        ;set national patient record flag if exist
-        S ECXDFN=DFN D NPRF^ECXUTL5 K ECXDFN
-        D:ECXENC'="" FILE^ECXPIVD2 K P1,P3
-        Q
-PAT(ECXDFN,ECXDATE,ECXERR)      ;get patient demographics, primary care, and inpatient data
-        N X
-        S (ECXCAT,ECXSTAT,ECXPRIOR,ECXSBGRP,ECXOEF,ECXOEFDT)=""
-        ;get patient data if saved
-        I $D(^TMP($J,"ECXP",ECXDFN)) D
-        .S PT=^TMP($J,"ECXP",ECXDFN),ECXPNM=$P(PT,U),ECXSSN=$P(PT,U,2),ECXMPI=$P(PT,U,3)
-        .S ECXDOB=$P(PT,U,4),ECXELIG=$P(PT,U,5),ECXSEX=$P(PT,U,6),ECXSTATE=$P(PT,U,7),ECXCNTY=$P(PT,U,8),ECXZIP=$P(PT,U,9)
-        .S ECXVET=$P(PT,U,10),ECXPOS=$P(PT,U,11),ECXPST=$P(PT,U,12),ECXPLOC=$P(PT,U,13),ECXRST=$P(PT,U,14),ECXAST=$P(PT,U,15)
-        .S ECXAOL=$P(PT,U,16),ECXPHI=$P(PT,U,17),ECXMST=$P(PT,U,18),ECXENRL=$P(PT,U,19),ECXCNHU=$P(PT,U,20),ECXCAT=$P(PT,U,21)
-        .S ECXSTAT=$P(PT,U,22),ECXPRIOR=$P(PT,U,23),ECXHNCI=$P(PT,U,24),ECXETH=$P(PT,U,25),ECXRC1=$P(PT,U,26),ECXMTST=$P(PT,U,27)
-        .S PT1=$G(^TMP($J,"ECXP",ECXDFN,1)),ECXERI=$P(PT1,U),ECXEST=$P(PT1,U,2),ECXOEF=$P(PT1,U,3),ECXOEFDT=$P(PT1,U,4)
-        .I $$ENROLLM^ECXUTL2(ECXDFN)
-        ;set patient data
-        I '$D(^TMP($J,"ECXP",ECXDFN)) D  Q:'OK
-        .K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECXDATE,"."),"1;2;3;5",.ECXPAT)
-        .I 'OK K ECXPAT S ECXERR=1 Q
-        .S ECXPNM=ECXPAT("NAME"),ECXSSN=ECXPAT("SSN"),ECXMPI=ECXPAT("MPI"),ECXDOB=ECXPAT("DOB"),ECXELIG=ECXPAT("ELIG"),ECXSEX=ECXPAT("SEX")
-        .S ECXSTATE=ECXPAT("STATE"),ECXCNTY=ECXPAT("COUNTY"),ECXZIP=ECXPAT("ZIP"),ECXVET=ECXPAT("VET")
-        .S ECXPOS=ECXPAT("POS"),ECXPST=ECXPAT("POW STAT"),ECXPLOC=ECXPAT("POW LOC"),ECXRST=ECXPAT("IR STAT")
-        .S ECXAST=ECXPAT("AO STAT"),ECXAOL=ECXPAT("AOL"),ECXPHI=ECXPAT("PHI"),ECXMST=ECXPAT("MST STAT")
-        .S ECXENRL=ECXPAT("ENROLL LOC"),ECXMTST=ECXPAT("MEANS"),ECXEST=ECXPAT("EC STAT")
-        .S ECXCNHU=$$CNHSTAT^ECXUTL4(ECXDFN) ;get CNHU status
-        .;get enrollment data (category, status and priority)
-        .I $$ENROLLM^ECXUTL2(ECXDFN)
-        .S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) ;Head and Neck Cancer Indicator
-        .; - Race and Ethnicity
-        .S ECXETH=ECXPAT("ETHNIC"),ECXRC1=ECXPAT("RACE1")
-        .S ECXERI=ECXPAT("ERI") ;emergency response indicator (FEMA)
-        .S ECXOEF=ECXPAT("ECXOEF")
-        .S ECXOEFDT=ECXPAT("ECXOEFDT")
-        .;save for later
-        .S ^TMP($J,"ECXP",ECXDFN)=ECXPNM_U_ECXSSN_U_ECXMPI_U_ECXDOB_U_ECXELIG_U_ECXSEX_U_ECXSTATE_U_ECXCNTY_U_ECXZIP_U_ECXVET_U_ECXPOS_U_ECXPST_U_ECXPLOC_U_ECXRST_U_ECXAST
-        .S ^TMP($J,"ECXP",ECXDFN)=^TMP($J,"ECXP",ECXDFN)_U_ECXAOL_U_ECXPHI_U_ECXMST_U_ECXENRL_U_ECXCNHU_U_ECXCAT_U_ECXSTAT_U_ECXPRIOR_U_ECXHNCI_U_ECXETH_U_ECXRC1_U_ECXMTST
-        .S ^TMP($J,"ECXP",ECXDFN,1)=ECXERI_U_ECXEST_U_ECXOEF_U_ECXOEFDT
-        ;get primary care data
-        S X=$$PRIMARY^ECXUTL2(ECXDFN,$P(ECXDATE,"."))
-        S ECPTTM=$P(X,U,1),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4),ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7)
-        ;get inpatient data
-        S (ECXA,ECXMN,ECXADM,ECXTS,ECXW,ECXDIV)="",X=$$INP^ECXUTL2(ECXDFN,ECXDATE)
-        S ECXA=$P(X,U),ECXMN=$P(X,U,2),ECXTS=$P(X,U,3),ECXADM=$P(X,U,4),W=$P(X,U,9),ECXDOM=$P(X,U,10),ECXW=$P(W,";"),ECXDIV=$P(W,";",2)
-        Q
-SETUP   ;Set required input for ECXTRAC
-        S ECHEAD="IVP"
-        D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
-        ;variables ecver and ecrtn will be reset in routine ecxtrac if appropriate
-        S ECVER=7
-        Q
-QUE     ; entry point for the background requeuing handled by ECXTAUTO
-        D SETUP,QUE^ECXTAUTO,^ECXKILL Q
+ECXPIVDN ;ALB/JAP,BIR/DMA,CML,PTD-Extract from IV EXTRACT DATA File (#728.113) ; 4/19/2007
+ ;;3.0;DSS EXTRACTS;**10,11,8,13,24,33,39,46,49,71,84,96,92,107**;Dec 22, 1997;Build 9
+START ; start package specific extract
+ N DIC,DA,DR,DIQ,DFN,ECXNPRFI,ECXPHA
+ S QFLG=0
+ I '$D(ECINST) D
+ .S ECINST=+$P(^ECX(728,1,0),U) K ECXDIC S DA=ECINST,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99"
+ .D EN^DIQ1 S ECINST=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC
+ S ECED=ECED+.3
+ K ^TMP($J,"A"),^TMP($J,"S")
+ S ECD=ECSD1
+ F  S ECD=$O(^ECX(728.113,"A",ECD)),DFN=0 Q:'ECD  Q:ECD>ECED  Q:QFLG  F  S DFN=$O(^ECX(728.113,"A",ECD,DFN)),ON=0  Q:'DFN  F  S ON=$O(^ECX(728.113,"A",ECD,DFN,ON)),DA=0 Q:'ON  K ^TMP($J,"A"),^TMP($J,"S") S ECVOL=0 D  Q:QFLG
+ .S ECXERR=0 D PAT(DFN,ECD,.ECXERR)
+ .Q:ECXERR
+ .F  S DA=$O(^ECX(728.113,"A",ECD,DFN,ON,DA)) Q:'DA  Q:QFLG  I $D(^ECX(728.113,DA,0)) S EC=^(0) D  Q:QFLG
+ ..S DRG=$P(EC,U,4) I $P(EC,U,8)]"" D
+ ...I '$D(^TMP($J,"A",DRG)) S ^(DRG)=$P(EC,U,7,8),^(DRG,1)=0,^(2)=$P(EC,U,12)
+ ...S ^(1)=^TMP($J,"A",DRG,1)+$S($P(EC,U,6)=1:1,$P(EC,U,6)=4:0,1:-1)
+ ..I $P(EC,U,9) D
+ ...I '$D(^TMP($J,"S",DRG)) S ^(DRG)=$P(EC,U,9)_"^ML",^(DRG,1)=0,^(2)=$P(EC,U,12),ECVOL=$P(EC,U,9)+ECVOL
+ ...S ^(1)=^TMP($J,"S",DRG,1)+$S($P(EC,U,6)=1:1,$P(EC,U,6)=4:0,1:-1)
+ ..S ECTYP=$P(EC,U,11),ECTOTC=0,ECDTTM=$$ECXTIME^ECXUTL($P(EC,U,5))
+ .;looped thru all DAs for this order - now put it together
+ .;leave the next line in case the decision is made to send volume designations
+ .;I ECTYP="H" S ECTYP=ECTYP_$S(ECVOL'>1000:1,ECVOL'>2000:2,1:3)
+ .S ECXDSSI=""
+ .;loop thru tmp global and call pharmacy drug file (#50) api
+ .F SA="S","A" S DRG="" F  S DRG=$O(^TMP($J,SA,DRG)) Q:DRG=""  S ECXPHA="",ECXPHA=$$PHAAPI^ECXUTL5(DRG) I $P(ECXPHA,U)'="" D STUFF Q:QFLG
+ K ^TMP($J),CLIN,DA,DFN,DIC,DIK,DRG,ON,SA,X,Y,P1,P3
+ Q
+STUFF ;get data
+ N ECORDST
+ S ECST=^TMP($J,SA,DRG),ECXCNT=^(DRG,1),ECXCOST=^(2),ECXCOST=ECXCOST*ECXCNT,ECVACL=$P(ECXPHA,U,2),ECORDST=""
+ ;if outpatient get division from iv rm; get dss identifier for clinic
+ I ECXA="O" D
+ .;- Only set ward to .5 if outpatient (but NOT observation patient)
+ .I $G(ECXW)="" S ECXW=.5
+ .I $P(EC,U,15) S ECIVRM=$P(EC,U,15),ECXDIV=$$PSJ59P5^ECXUTL5(ECIVRM)
+ .S CLIN=+$P(EC,U,13),(ECXP1,ECXP2)="000",ECXCL=$G(^ECX(728.44,CLIN,0)) Q:ECXCL=""
+ .S ECSC=$P(ECXCL,U,4),ECCSC=$P(ECXCL,U,5)
+ .I ECSC="" S ECSC=$P(ECXCL,U,2),ECCSC=$P(ECXCL,U,3)
+ .I ECSC S ECXP1=$$RJ^XLFSTR(ECSC,3,0),ECXP2=$$RJ^XLFSTR(ECCSC,3,0)
+ .I ECSC="" S ECSC=$P($G(^SC(ECXCL,0)),U,7),ECCSC=$P($G(^SC(ECXCL,0)),U,18) I ECSC D
+ ..S ECXP1=$P($G(^DIC(40.7,ECSC,0)),U,2) S:ECCSC]"" ECXP2=$P($G(^DIC(40.7,ECCSC,0)),U,2)
+ ..S ECXP1=$$RJ^XLFSTR(ECXP1,3,0),ECXP2=$$RJ^XLFSTR(ECXP2,3,0)
+ .S ECXDSSI=ECXP1_ECXP2
+ .I ECXLOGIC>2003 D
+ ..I "^18^23^24^36^41^65^94^"[("^"_ECXTS_"^") S ECXDSSI=$$TSMAP^ECXUTL4(ECXTS)
+ S ECINV=$P(ECXPHA,U,4),ECINV=$S(ECINV["I":"I",1:""),ECST=ECXCNT*ECST_" "_$P(ECST,U,2)
+ S ECNDC=$P(ECXPHA,U,3),ECNFC=$$RJ^XLFSTR($P(ECNDC,"-"),6,0)_$$RJ^XLFSTR($P(ECNDC,"-",2),4,0)_$$RJ^XLFSTR($P(ECNDC,"-",3),2,0),ECNFC=$TR(ECNFC,"*",0)
+ S P1=$P(ECXPHA,U,5),P3=$P(ECXPHA,U,6)
+ S X="PSNAPIS" X ^%ZOSF("TEST") I $T S ECNFC=$$DSS^PSNAPIS(P1,P3,ECXYM)_ECNFC
+ I $L(ECNFC)=12 S ECNFC=$$RJ^XLFSTR(P1,4,0)_$$RJ^XLFSTR(P3,3,0)_ECNFC
+ ;- Ordering provider ("2"_provider)
+ S ECXORDPR=$S(+$P(EC,U,10):"2"_$P(EC,U,10),1:""),ECXOPNPI=""
+ S ECXORDDT=$P(EC,U,16) ;- Ordering date
+ ;- Requesting physician (null for FY2002)
+ S ECXRPHY=""
+ ;- Department and National Prod Division
+ S ECXDSSD="" ;dss department use postponed $$IVP^ECXDEPT(ECXDIV)
+ N ECXPDIV S ECXPDIV=$$GETDIV^ECXDEPT(ECXDIV)
+ ;- Observation patient indicator (yes/no)
+ S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXDSSI)
+ ; - Ordering Date, Ordering Stop Code
+ S ECXORDST="" I ECXA="O" D
+ .S ECXORDST=$$DOIVPO^ECXUTL5(DFN,ON)
+ .I ECXOBS="NO" S ECORDST="160"
+ .I ECXOBS="YES" S ECORDST=$P($G(^ECX(727.831,+ECXTS,0)),U,6)
+ ;- If no encounter number don't file record
+ S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADM,ECD,ECXTS,ECXOBS,ECHEAD,ECORDST,)
+ ;get BCMA data
+ S (ECXBCDD,ECXBCDG,ECXBCUA,ECXBCIF)=""
+ ;get ordering provider person class
+ S ECXOPPC=$$PRVCLASS^ECXUTL($E(ECXORDPR,2,999),ECXORDDT)
+ ;set national patient record flag if exist
+ S ECXDFN=DFN D NPRF^ECXUTL5 K ECXDFN
+ D:ECXENC'="" FILE K P1,P3
+ Q
+PAT(ECXDFN,ECXDATE,ECXERR) ;get patient demographics, primary care, and inpatient data
+ N X
+ S (ECXCAT,ECXSTAT,ECXPRIOR,ECXSBGRP)=""
+ ;get patient data if saved
+ I $D(^TMP($J,"ECXP",ECXDFN)) D
+ .S PT=^TMP($J,"ECXP",ECXDFN),ECXPNM=$P(PT,U),ECXSSN=$P(PT,U,2),ECXMPI=$P(PT,U,3)
+ .S ECXDOB=$P(PT,U,4),ECXELIG=$P(PT,U,5),ECXSEX=$P(PT,U,6),ECXSTATE=$P(PT,U,7),ECXCNTY=$P(PT,U,8),ECXZIP=$P(PT,U,9)
+ .S ECXVET=$P(PT,U,10),ECXPOS=$P(PT,U,11),ECXPST=$P(PT,U,12),ECXPLOC=$P(PT,U,13),ECXRST=$P(PT,U,14),ECXAST=$P(PT,U,15)
+ .S ECXAOL=$P(PT,U,16),ECXPHI=$P(PT,U,17),ECXMST=$P(PT,U,18),ECXENRL=$P(PT,U,19),ECXCNHU=$P(PT,U,20),ECXCAT=$P(PT,U,21)
+ .S ECXSTAT=$P(PT,U,22),ECXPRIOR=$P(PT,U,23),ECXHNCI=$P(PT,U,24),ECXETH=$P(PT,U,25),ECXRC1=$P(PT,U,26),ECXMTST=$P(PT,U,27)
+ .S PT1=$G(^TMP($J,"ECXP",ECXDFN,1)),ECXERI=$P(PT1,U),ECXEST=$P(PT1,U,2)
+ .I $$ENROLLM^ECXUTL2(ECXDFN)
+ ;set patient data
+ I '$D(^TMP($J,"ECXP",ECXDFN)) D  Q:'OK
+ .K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECXDATE,"."),"1;2;3;5",.ECXPAT)
+ .I 'OK K ECXPAT S ECXERR=1 Q
+ .S ECXPNM=ECXPAT("NAME"),ECXSSN=ECXPAT("SSN"),ECXMPI=ECXPAT("MPI"),ECXDOB=ECXPAT("DOB"),ECXELIG=ECXPAT("ELIG"),ECXSEX=ECXPAT("SEX")
+ .S ECXSTATE=ECXPAT("STATE"),ECXCNTY=ECXPAT("COUNTY"),ECXZIP=ECXPAT("ZIP"),ECXVET=ECXPAT("VET")
+ .S ECXPOS=ECXPAT("POS"),ECXPST=ECXPAT("POW STAT"),ECXPLOC=ECXPAT("POW LOC"),ECXRST=ECXPAT("IR STAT")
+ .S ECXAST=ECXPAT("AO STAT"),ECXAOL=ECXPAT("AOL"),ECXPHI=ECXPAT("PHI"),ECXMST=ECXPAT("MST STAT")
+ .S ECXENRL=ECXPAT("ENROLL LOC"),ECXMTST=ECXPAT("MEANS"),ECXEST=ECXPAT("EC STAT")
+ .S ECXCNHU=$$CNHSTAT^ECXUTL4(ECXDFN) ;get CNHU status
+ .;get enrollment data (category, status and priority)
+ .I $$ENROLLM^ECXUTL2(ECXDFN)
+ .S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) ;Head and Neck Cancer Indicator
+ .; - Race and Ethnicity
+ .S ECXETH=ECXPAT("ETHNIC"),ECXRC1=ECXPAT("RACE1")
+ .S ECXERI=ECXPAT("ERI") ;emergency response indicator (FEMA)
+ .;save for later
+ .S ^TMP($J,"ECXP",ECXDFN)=ECXPNM_U_ECXSSN_U_ECXMPI_U_ECXDOB_U_ECXELIG_U_ECXSEX_U_ECXSTATE_U_ECXCNTY_U_ECXZIP_U_ECXVET_U_ECXPOS_U_ECXPST_U_ECXPLOC_U_ECXRST_U_ECXAST
+ .S ^TMP($J,"ECXP",ECXDFN)=^TMP($J,"ECXP",ECXDFN)_U_ECXAOL_U_ECXPHI_U_ECXMST_U_ECXENRL_U_ECXCNHU_U_ECXCAT_U_ECXSTAT_U_ECXPRIOR_U_ECXHNCI_U_ECXETH_U_ECXRC1_U_ECXMTST
+ .S ^TMP($J,"ECXP",ECXDFN,1)=ECXERI_U_ECXEST
+ ;get primary care data
+ S X=$$PRIMARY^ECXUTL2(ECXDFN,$P(ECXDATE,"."))
+ S ECPTTM=$P(X,U,1),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4),ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7)
+ ;get inpatient data
+ S (ECXA,ECXMN,ECXADM,ECXTS,ECXW,ECXDIV)="",X=$$INP^ECXUTL2(ECXDFN,ECXDATE)
+ S ECXA=$P(X,U),ECXMN=$P(X,U,2),ECXTS=$P(X,U,3),ECXADM=$P(X,U,4),W=$P(X,U,9),ECXDOM=$P(X,U,10),ECXW=$P(W,";"),ECXDIV=$P(W,";",2)
+ Q
+FILE ;file record
+ ;node0
+ ;fac^dfn^ssn^name^i/o^day^va class^qty^ward^cost^movement #^treat spec^ndc^investigational^iv dispensing fee^new feeder key^total doses^
+ ;primary care team^primary care provider^ivp time^adm date^adm time^dss identifier
+ ;node1
+ ;mpi^dss dept^pc provider npi^pc prov person class^assoc pc provider^assoc pc prov person class^assoc pc prov npi^dom^obs pat ind^enc num^
+ ;ord pr^ordering stop code^ord dt^req phys^nat prod division^means tst^elig^dob^sex^state^county^zip+4^vet^period of svc^pow stat^pow loc^ir stat^ao stat^
+ ;ao loc^purple heart ind.^mst stat^enrollment loc^enrollment cat^enrollment stat^enrollment prior^cnh/sh stat^ord pr npi
+ ;node2
+ ;head & neck cancer ind.^ethnicity^race1^bcma drug dispensed^bcma dose given^bcma unit of administration^bcma ICU flag^
+ ;ordering provider person class^^user enrollee ECXUESTA^patient type ECXPTYPE^combat vet elig ECXCVE^
+ ;combat vet elig end date ECXCVEDT^enc cv eligible ECXCVENC^national patient record flag ECXNPRFI^emerg resp indic(FEMA) ECXERI^
+ ;environ contamin ECXEST
+ N DA,DIK
+ S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1
+ S ECODE=EC7_U_EC23_U_ECXDIV_U_DFN_U_ECXSSN_U_ECXPNM_U_ECXA_U
+ S ECODE=ECODE_$$ECXDATE^ECXUTL(ECD,ECXYM)_U_ECVACL_U_ECXCNT_U_ECXW_U
+ ;convert specialty to PTF Code for transmission
+ N ECXDATA
+ S ECXDATA=$$TSDATA^DGACT(42.4,+ECXTS,.ECXDATA)
+ S ECXTS=$G(ECXDATA(7))
+ ;done
+ S ECODE=ECODE_ECXCOST_U_ECXMN_U_ECXTS_U_ECNDC_U_ECINV_U_ECTYP_U_ECNFC_U
+ S ECODE=ECODE_ECST_U_ECPTTM_U_ECPTPR_U_ECDTTM_U_$$ECXDATE^ECXUTL(ECXADM,ECXYM)_U_$$ECXTIME^ECXUTL(ECXADM)_U_ECXDSSI_U
+ ;if outpat and not observ patient, admit date="" and admit time="000000"
+ I ECXA="O",(ECXOBS="NO") S $P(ECODE,U,24)="",$P(ECODE,U,25)="000000"
+ S ECODE1=ECXMPI_U_ECXDSSD_U_ECPTNPI_U_ECCLAS_U_ECASPR_U_ECCLAS2_U_ECASNPI_U_ECXDOM_U_ECXOBS_U_ECXENC_U_ECXORDPR_U
+ S ECODE1=ECODE1_ECXORDST_U_$$ECXDATE^ECXUTL(ECXORDDT,ECXYM)_U_ECXRPHY_U_ECXPDIV_U_ECXMTST_U_ECXELIG_U_ECXDOB_U
+ S ECODE1=ECODE1_ECXSEX_U_ECXSTATE_U_ECXCNTY_U_ECXZIP_U_ECXVET_U_ECXPOS_U_ECXPST_U_ECXPLOC_U_ECXRST_U_ECXAST_U
+ S ECODE1=ECODE1_ECXAOL_U_ECXPHI_U_ECXMST_U_ECXENRL_U_ECXCAT_U
+ S ECODE1=ECODE1_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXCNHU_U_ECXOPNPI_U
+ S ECODE2=ECXHNCI_U_ECXETH_U_ECXRC1
+ I ECXLOGIC>2003 D
+ .S ECODE2=ECODE2_U_ECXBCDD_U_ECXBCDG_U_ECXBCUA_U_ECXBCIF_U_ECXOPPC
+ I ECXLOGIC>2004 S ECODE2=ECODE2_U_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXNPRFI
+ I ECXLOGIC>2006 S ECODE2=ECODE2_U_ECXERI_U_ECXEST
+ S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1
+ S ^ECX(ECFILE,EC7,2)=ECODE2,ECRN=ECRN+1
+ S DA=EC7,DIK="^ECX("_ECFILE_"," D IX^DIK K DIK,DA
+ I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1
+ Q
+SETUP ;Set required input for ECXTRAC
+ S ECHEAD="IVP"
+ D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
+ ;variables ecver and ecrtn will be reset in routine ecxtrac if appropriate
+ S ECVER=7
+ Q
+QUE ; entry point for the background requeuing handled by ECXTAUTO
+ D SETUP,QUE^ECXTAUTO,^ECXKILL Q

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXPLBB.m

@@ -1 @@
-ECXPLBB ;DALOI/KML - DSS BLOOD BANK PRE-EXTRACT AUDIT REPORT ; 8/13/07 7:08am
-        ;;3.0;DSS EXTRACTS;**78,92,105**;Dec 22, 1997;Build 70
-        ;Per VHA Directive 97-033 this routine should not be modified.  Medical Device # BK970021
-        ;entry point from option
-        D SETUP^ECXLBB I ECFILE="" Q
-        N ECXINST
-        D DATES
-        Q:ECED']""&(ECSD']"")
-        N ECXPOP S ECXPOP=0 D QUE Q:ECXPOP
-        ;
-START   ;  entry point from tasked job
-        ; get LAB DATA and build temporary global ^TMP("ECXLBB",$J)
-        N ECTRSP,ECADMT,ECTODT,ECXRPT,ECOUT,ECXSTR,ECRDT,ECLINE,ECPG,ECQUIT
-        N ECD,ECXDFN,ECARRY,EC66,ECERR,ECTRFDT,ECTRFTM,ECX,ECINOUT,ECXJOB
-        N ECXLOGIC
-        S ECXJOB=$J
-        K ^TMP("ECXLBB",ECXJOB)
-        U IO
-        I $E(IOST,1,2)="C-" W !,"Retrieving records... "
-        S ECXRPT=1 D AUDRPT^ECXLBB
-OUTPUT  ; entry point called by EN tag
-        I '$D(^TMP("ECXLBB",ECXJOB)) W !,"There were no records that met the date range criteria" Q
-        S (ECPG,ECDATE,ECQUIT,ECXDFN)=0,ECLINE="",$P(ECLINE,"=",80)="="
-        S ECSDN=$$FMTE^XLFDT(ECSD,9),ECEDN=$$FMTE^XLFDT(ECED,9),ECRDT=$$FMTE^XLFDT(DT,9)
-        W:$E(IOST,1,2)="C-" @IOF D HED
-        F  S ECXDFN=$O(^TMP("ECXLBB",ECXJOB,ECXDFN)) Q:'ECXDFN  F  S ECDATE=$O(^TMP("ECXLBB",ECXJOB,ECXDFN,ECDATE))  Q:'ECDATE  Q:ECQUIT  S ECXSTR=^(ECDATE) D PRINT
-        D ^ECXKILL
-        Q
-        ;
-PRINT   ;
-        I $Y+5>IOSL D  Q:ECQUIT
-        . I $E(IOST,1,2)["C-" S DIR(0)="E" D ^DIR K DIR I 'Y S ECQUIT=1 Q
-        . W @IOF D HED
-        W !,$P(ECXSTR,"^",5),?11,$P(ECXSTR,"^",4),?26,$P(ECXSTR,"^",16)
-        W ?37,$$FMTE^XLFDT($$HL7TFM^XLFDT($P(ECXSTR,"^",8)),2)
-        W ?49,$P(ECXSTR,"^",11),?60,$J(+$P(ECXSTR,"^",12),2)
-        Q
-        ;
-HED     ;
-        S ECPG=ECPG+1
-        W !,"LBB Extract Audit Report",?72,"Page",$J(ECPG,3)
-        W !,ECSDN," - ",ECEDN,?58,"Run Date:",$J(ECRDT,12)
-        W !,?37,"Transf",?57,"Number"
-        W !,"Name",?14,"SSN",?25,"FDR LOC",?37,"Date",?49,"COMP"
-        W ?57,"of Units"
-        W !,ECLINE
-        Q
-DATES   ;
-        N OUT,CHKFLG
-        I '$D(ECNODE) S ECNODE=7
-        I '$D(ECHEAD) S ECHEAD=" "
-        W @IOF,!,"LBB Extract Audit Report Information for DSS",!!
-        S:'$D(ECINST) ECINST=+$P(^ECX(728,1,0),U)
-        S ECXINST=ECINST
-        K ECXDIC S DA=ECINST,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99"
-        D EN^DIQ1 S ECINST=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC
-        S ECLDT=$S($D(^ECX(728,1,ECNODE)):$P(^(ECNODE),U,ECPIECE),1:2610624)
-        S:ECLDT="" ECLDT=2610624
-        S ECOUT=0 F  S (ECED,ECSD)="" D  Q:ECOUT
-        . K %DT S %DT="AEX",%DT("A")="Starting with Date: " D ^%DT
-        . I Y<0 S ECOUT=1 Q
-        . S ECSD=Y
-        . K %DT S %DT="AEX",%DT("A")="Ending with Date: " D ^%DT
-        . I Y<0 S ECOUT=1 Q
-        . I Y<ECSD W !!,"The ending date cannot be earlier than the starting date.",!,"Please try again.",!! Q
-        . 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
-        . S ECED=Y
-        . I ECLDT'<ECSD W !!,"The Blood Bank information has already been extracted through ",$$FMTE^XLFDT(ECLDT),".",!,"Please enter a new date range.",!! Q
-        . S ECOUT=1
-        Q
-        ;
-QUE     ;
-        K ZTSAVE
-        S ECSDN=$$FMTE^XLFDT(ECSD),ECEDN=$$FMTE^XLFDT(ECED),ECSD1=ECSD-.1
-        K ZTSAVE
-        F X="ECINST","ECED","ECSD","ECSD1","ECEDN","ECSDN" S ZTSAVE(X)=""
-        F X="ECPACK","ECPIECE","ECRTN","ECGRP","ECNODE" S ZTSAVE(X)=""
-        F X="ECFILE","ECHEAD","ECVER","ECINST","ECXINST" S ZTSAVE(X)=""
-        F X="ECXLOGIC","ECXDATES" S ZTSAVE(X)=""
-        S ZTDESC=ECPACK_" EXTRACT AUDIT REPORT: "_ECSDN_" TO "_ECEDN,ZTRTN="START^ECXPLBB",ZTIO=""
-        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
-        Q
-        ;
-EN(ECXJOB,ECSD,ECED)    ; entry point used primarily for testing
-        ; input:
-        ;        ECXJOB = $J that is assigned to the 2nd subscript of 
-        ;                 the temporary global array containing the 
-        ;                 extracted data that feeds the pre-extract
-        ;                 audit report
-        ;        ECSD   = starting date range representing the FM
-        ;                 date used to retrieve data from file #63
-        ;        ECED   = ending date range representing the FM date
-        ;                 used to retrieve data from file #63
-        ; syntax  of the call: D EN^ECXPLBB(541571372,3000101,3000131)
-        D OUTPUT
-        Q
-        ;
-        ;ECXPLBB
+ECXPLBB ;DALOI/KML - DSS BLOOD BANK PRE-EXTRACT AUDIT REPORT ; 8/14/06 10:10am
+ ;;3.0;DSS EXTRACTS;**78,92**;Dec 22, 1997;Build 30
+ ;Per VHA Directive 97-033 this routine should not be modified.  Medical Device # BK970021
+ ;entry point from option
+ D SETUP^ECXLBB I ECFILE="" Q
+ N ECXINST
+ D DATES
+ Q:ECED']""&(ECSD']"")
+ N ECXPOP S ECXPOP=0 D QUE Q:ECXPOP
+ ;
+START ;  entry point from tasked job
+ ; get LAB DATA and build temporary global ^TMP("ECXLBB",$J)
+ N ECTRSP,ECADMT,ECTODT,ECXRPT,ECOUT,ECXSTR,ECRDT,ECLINE,ECPG,ECQUIT
+ N ECD,ECXDFN,ECARRY,EC66,ECERR,ECTRFDT,ECTRFTM,ECX,ECINOUT,ECXJOB
+ N ECXLOGIC
+ S ECXJOB=$J
+ K ^TMP("ECXLBB",ECXJOB)
+ U IO
+ I $E(IOST,1,2)="C-" W !,"Retrieving records... "
+ S ECXRPT=1 D AUDRPT^ECXLBB
+OUTPUT ; entry point called by EN tag
+ I '$D(^TMP("ECXLBB",ECXJOB)) W !,"There were no records that met the date range criteria" Q
+ S (ECPG,ECDATE,ECQUIT,ECXDFN)=0,ECLINE="",$P(ECLINE,"=",80)="="
+ S ECSDN=$$FMTE^XLFDT(ECSD,9),ECEDN=$$FMTE^XLFDT(ECED,9),ECRDT=$$FMTE^XLFDT(DT,9)
+ W:$E(IOST,1,2)="C-" @IOF D HED
+ F  S ECXDFN=$O(^TMP("ECXLBB",ECXJOB,ECXDFN)) Q:'ECXDFN  F  S ECDATE=$O(^TMP("ECXLBB",ECXJOB,ECXDFN,ECDATE))  Q:'ECDATE  Q:ECQUIT  S ECXSTR=^(ECDATE) D PRINT
+ D ^ECXKILL
+ Q
+ ;
+PRINT ;
+ I $Y+5>IOSL D  Q:ECQUIT
+ . I $E(IOST,1,2)["C-" S DIR(0)="E" D ^DIR K DIR I 'Y S ECQUIT=1 Q
+ . W @IOF D HED
+ W !,$P(ECXSTR,"^",5),?11,$P(ECXSTR,"^",4),?26,$P(ECXSTR,"^",16)
+ W ?37,$$FMTE^XLFDT($$HL7TFM^XLFDT($P(ECXSTR,"^",8)),2)
+ W ?49,$P(ECXSTR,"^",11),?60,$J(+$P(ECXSTR,"^",12),2)
+ Q
+ ;
+HED ;
+ S ECPG=ECPG+1
+ W !,"LBB Pre-Extract Audit Report",?72,"Page",$J(ECPG,3)
+ W !,ECSDN," - ",ECEDN,?58,"Run Date:",$J(ECRDT,12)
+ W !,?37,"Transf",?57,"Number"
+ W !,"Name",?14,"SSN",?25,"FDR LOC",?37,"Date",?49,"COMP"
+ W ?57,"of Units"
+ W !,ECLINE
+ Q
+DATES ;
+ N OUT,CHKFLG
+ I '$D(ECNODE) S ECNODE=7
+ I '$D(ECHEAD) S ECHEAD=" "
+ W @IOF,!,"LBB Pre-Extract Audit Report Information for DSS",!!
+ S:'$D(ECINST) ECINST=+$P(^ECX(728,1,0),U)
+ S ECXINST=ECINST
+ K ECXDIC S DA=ECINST,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99"
+ D EN^DIQ1 S ECINST=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC
+ S ECLDT=$S($D(^ECX(728,1,ECNODE)):$P(^(ECNODE),U,ECPIECE),1:2610624)
+ S:ECLDT="" ECLDT=2610624
+ S ECOUT=0 F  S (ECED,ECSD)="" D  Q:ECOUT
+ . K %DT S %DT="AEX",%DT("A")="Starting with Date: " D ^%DT
+ . I Y<0 S ECOUT=1 Q
+ . S ECSD=Y
+ . K %DT S %DT="AEX",%DT("A")="Ending with Date: " D ^%DT
+ . I Y<0 S ECOUT=1 Q
+ . I Y<ECSD W !!,"The ending date cannot be earlier than the starting date.",!,"Please try again.",!! Q
+ . 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
+ . S ECED=Y
+ . I ECLDT'<ECSD W !!,"The Blood Bank information has already been extracted through ",$$FMTE^XLFDT(ECLDT),".",!,"Please enter a new date range.",!! Q
+ . S ECOUT=1
+ Q
+ ;
+QUE ;
+ K ZTSAVE
+ S ECSDN=$$FMTE^XLFDT(ECSD),ECEDN=$$FMTE^XLFDT(ECED),ECSD1=ECSD-.1
+ K ZTSAVE
+ F X="ECINST","ECED","ECSD","ECSD1","ECEDN","ECSDN" S ZTSAVE(X)=""
+ F X="ECPACK","ECPIECE","ECRTN","ECGRP","ECNODE" S ZTSAVE(X)=""
+ F X="ECFILE","ECHEAD","ECVER","ECINST","ECXINST" S ZTSAVE(X)=""
+ F X="ECXLOGIC","ECXDATES" S ZTSAVE(X)=""
+ S ZTDESC=ECPACK_" PRE-EXTRACT AUDIT REPORT: "_ECSDN_" TO "_ECEDN,ZTRTN="START^ECXPLBB",ZTIO=""
+ 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
+ Q
+ ;
+EN(ECXJOB,ECSD,ECED) ; entry point used primarily for testing
+ ; input:
+ ;        ECXJOB = $J that is assigned to the 2nd subscript of 
+ ;                 the temporary global array containing the 
+ ;                 extracted data that feeds the pre-extract
+ ;                 audit report
+ ;        ECSD   = starting date range representing the FM
+ ;                 date used to retrieve data from file #63
+ ;        ECED   = ending date range representing the FM date
+ ;                 used to retrieve data from file #63
+ ; syntax  of the call: D EN^ECXPLBB(541571372,3000101,3000131)
+ D OUTPUT
+ Q
+ ;
+ ;ECXPLBB

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXPRO.m

@@ -1 @@
-ECXPRO  ;ALB/GTS - Prosthetics Extract for DSS ; 10/17/07 3:47pm
-        ;;3.0;DSS EXTRACTS;**9,13,15,21,24,33,39,46,71,92,105**;Dec 22, 1997;Build 70
-BEG     ;entry point from option
-        D SETUP I ECFILE="" Q
-        D:+ECINST>0 ^ECXTRAC D ^ECXKILL
-        Q
-        ;
-START   ;start package specific extract
-        ;
-        ; Input
-        ;  ECSD1   - FM formatted Beginning Date (Set by ECXTRAC)
-        ;  ECED    - FM formatted End Date (Set by ECXTRAC)
-        ;  ECSDN   - Externally formatted Start Date (Set by ECXTRAC)
-        ;  ECEDN   - Externally formatted End Date (Set by ECXTRAC)
-        ;  EC      - IEN from file #727 (Set by ECXTRAC)
-        ;  ECXYM   - Year and Month of extract (YYYYMM)
-        ;  ECXINST - IEN for division in file #4
-        ;  ECINST  - Station number of selected division
-        ;
-        N ECXLNE,ECXCT,ECXDACT,ECX0,ECXLB,ECXED1,ECINSTSV,ECXLNSTR,ECXP
-        N DIC,DR,DA,DIQ,CPTCODE,ECXNPRFI
-        D ECXBUL^ECXPRO2(.ECXLNE,ECSDN,ECEDN,EC)
-        S QFLG=0,ECXLNSTR=ECXLNE,ECXED1=ECED+.9999,ECXCT=ECSD1
-        F  S ECXCT=$O(^RMPR(660,"CT",ECXCT)) Q:(ECXCT>ECXED1)!('ECXCT)!(QFLG=1)  D
-        .S ECXDACT=0
-        .F  S ECXDACT=$O(^RMPR(660,"CT",ECXCT,ECXDACT)) Q:('ECXDACT)!(QFLG=1)  D
-        ..;* initialize variables
-        ..S (ECXDFN,ECXPNM,ECXSSN,ECXSEX,ECXSTAT,ECXDATE,ECXTYPE,ECXSRCE)=""
-        ..S (ECXHCPCS,ECXPHCPC,ECXRQST,ECXRCST,ECXFORM,ECXCTAMT,ECXLLC)=""
-        ..S (ECXLMC,ECXGRPR,ECXBILST,ECXQTY,ECXFELOC,ECXFEKEY,ECXA)=""
-        ..S (ECPTTM,ECPTPR,ECXAST,ECXRST,ECXEST,ECXELIG,ECXVET,ECXZIP)=""
-        ..S (ECXDOB,ECXDSSD,ECXICD9,ECXAOL,ECXHNCI,ECXETH,ECXRC1,ECXMST)=""
-        ..F I=1:1:4 S @("ECXICD9"_I)=""
-        ..Q:'$D(^RMPR(660,ECXDACT,0))
-        ..S ECX0=^RMPR(660,ECXDACT,0),ECXLB=$G(^RMPR(660,ECXDACT,"LB"))
-        ..K ECXP S DIC="^RMPR(660,",DR=".02;11",DA=ECXDACT,DIQ(0)="EI"
-        ..S DIQ="ECXP" D EN^DIQ1
-        ..S ECXDIV=$$GET1^DIQ(660,ECXDACT,8,"I")
-        ..S ECXDFN=$G(ECXP(660,ECXDACT,.02,"I"))
-        ..S ECXFORM=$G(ECXP(660,ECXDACT,11,"E"))_U_$G(ECXP(660,ECXDACT,11,"I"))
-        ..Q:'$$PATDEM^ECXUTL2(ECXDFN,ECXCT)
-        ..S OK=$$PAT^ECXUTL3(ECXDFN,ECXDATE,"1;5",.ECXPAT)
-        ..I 'OK S ECXERR=1 K ECXPAT Q
-        ..;OEF/OIF data
-        ..S ECXOEF=ECXPAT("ECXOEF")
-        ..S ECXOEFDT=ECXPAT("ECXOEFDT")
-        ..Q:'$$NTEG^ECXPRO1(ECXDFN,.ECXLNE,ECXDACT,ECX0,ECXLB,ECINST,ECXFORM)
-        ..D PROSINFO^ECXPRO1(ECXDACT,ECXLB,ECX0,ECXFORM)
-        ..S CPTCODE=$E(ECXHCPCS,1,5)
-        ..;nppd entry date
-        ..S ECXNPPDT=$$ECXDATE^ECXUTL($P(ECX0,U,1),ECXYM)
-        ..;
-        ..;Get production division ;p-46
-        ..N ECXPDIV S ECXPDIV=$$RADDIV^ECXDEPT(ECXDIV) ;p-46
-        ..;- Observation patient indicator (YES/NO)
-        ..S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS)
-        ..;
-        ..;- CNH status (YES/NO)
-        ..S ECXCNH=$$CNHSTAT^ECXUTL4(ECXDFN)
-        ..;
-        ..;get encounter classifications
-        ..S (ECXAO,ECXECE,ECXHNC,ECXMIL,ECXIR)=""
-        ..S ECXVISIT=$$GET1^DIQ(660,ECXDACT,8.12,"I") I ECXVISIT'="" D
-        ...D VISIT^ECXSCX1(ECXDFN,ECXVISIT,.ECXVIST,.ECXERR) I ECXERR K ECXERR Q
-        ...S ECXAO=$G(ECXVIST("AO")),ECXECE=$G(ECXVIST("PGE"))
-        ...S ECXHNC=$G(ECXVIST("HNC")),ECXMIL=$G(ECXVIST("MST")),ECXIR=$G(ECXVIST("IR"))
-        ..; - Head and Neck Cancer Indicator
-        ..S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN)
-        ..;
-        ..; - set national patient record flag if exist
-        ..D NPRF^ECXUTL5
-        ..;
-        ..;- If no encounter number don't file record
-        ..S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,,) Q:ECXENC=""
-        ..I ECXFORM["-3" F ECXLAB="LAB","ORD" D
-        ...D FEEDINFO^ECXPRO2(ECXSRCE,CPTCODE,ECXTYPE,ECXSTAT2,ECXRQST,ECXRCST,ECXLAB)
-        ...Q:ECXFELOC=""  D FILE
-        ..I ECXFORM'["-3" S ECXLAB="NONL" D
-        ...D FEEDINFO^ECXPRO2(ECXSRCE,CPTCODE,ECXTYPE,ECXSTAT2,ECXRQST,ECXRCST,ECXLAB)
-        ...Q:ECXFELOC=""  D FILE
-        ;* Send the Exception message
-        I ECXLNSTR<ECXLNE DO
-        .K XMY S XMY("G.DSS-"_ECGRP_"@"_^XMB("NETNAME"))=""
-        .S XMDUZ=.5
-        .S XMSUB=ECINST_" - Prosthetics DSS Exception Message",XMN=0
-        .S XMTEXT="^TMP(""ECX-PRO EXC"",$J,"
-        .D ^XMD
-        K ^TMP("ECX-PRO EXC",$J),XMDUZ,XMSUB,XMTEXT,XMY
-        Q
-        ;
-FILE    ;file extract record
-        ;node0
-        ;facility^dfn (ECXDFN)^ssn (ECXSSN)^name (ECXPNM)^in/out (ECXA)^
-        ;day^feeder location^
-        ;feeder key^qty^pc team^pc provider^hcpcs^icd9 (ECXICD9)^
-        ;icd9-1 (ECXICD91)^icd9-2 (ECXICD92)^icd9-3 (ECXICD93)^
-        ;icd9-4 (ECXICD94)^agent orange^radiation^env contam^eligibility^
-        ;cost^lab labor cost^lab matl cost^billing status^
-        ;vet^transaction type^req station^rec station^file#661.1 ien
-        ;node1
-        ;zip^dob^sex^amis grouper^placeholder^mpi^dss dept ECXDSSD^
-        ;pc prov person class^race^pow status^pow loc^
-        ;sharing agree payor^sharing agree ins^mst status^
-        ;enroll loc^state^county^assoc pc provider^
-        ;assoc pc prov person class^placeholder
-        ;dom (ECXDOM)^purple heart indicator (ECXPHI)^
-        ;enrollment Category (ECXCAT)^enrollment status (ECXSTAT)^
-        ;enrollment priority (ECXPRIOR)^purple heart ind (ECXPHI)^
-        ;period of serv (ECXPOS)^observ pat ind (ECXOBS)^encounter num (ECXENC)^
-        ;ao loc (ECXAOL)^CNH status (ECXCNH)^production division ECXPDIV^
-        ;head & neck canc. ind. (ECXHNCI)^ethnicity (ECXETH)^race1 (ECXRC1)^
-        ;^enrollment priority (ECXPRIOR)_enrollment sub-
-        ;group (ECXSBGRP)^user enrollee (ECXUESTA)^patient type ECXPTYPE
-        ;^combat vet elig ECXCVE^combat vet elig end date ECXCVEDT^enc cv
-        ;eligible ECXCVENC^national patient record flag ECXNPRFI^
-        ;emergency response indicator(FEMA) ECXERI^agent orange indicator ECXAO
-        ;^environ contam ECXECE^head/neck cancer ECXHNC^encntr mst ECXMIL^
-        ;radiation ECXIR^OEF/OIF ECXOEF^OEF/OIF return date ECXOEFDT^
-        ;nppd code ECXNPPDC^nppd entry date ECXNPPDT
-        ;assoc pc provider npi ECASNPI^primary care provider npi ECPTNPI
-        N DA,DIK
-        S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1
-        S ECODE=EC7_U_EC23_U_ECINST_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U
-        S ECODE=ECODE_$$ECXDATE^ECXUTL(ECXDATE,ECXYM)_U_ECXFELOC_U
-        S ECODE=ECODE_ECXFEKEY_U_ECXQTY_U_ECPTTM_U_ECPTPR_U_ECXHCPCS_U
-        S ECODE=ECODE_ECXICD9_U_ECXICD91_U_ECXICD92_U_ECXICD93_U_ECXICD94_U
-        S ECODE=ECODE_ECXAST_U_ECXRST_U_ECXEST_U_ECXELIG_U_ECXCTAMT_U_ECXLLC_U
-        S ECODE=ECODE_ECXLMC_U_ECXBILST_U_ECXVET_U_ECXTYPE_U_ECXRQST_U_ECXRCST_U
-        S ECODE=ECODE_ECXPHCPC_U
-        S ECODE1=ECXZIP_U_ECXDOB_U_ECXSEX_U_ECXGRPR_U_U_ECXMPI_U
-        S ECODE1=ECODE1_ECXDSSD_U_ECCLAS_U_ECXRACE_U_ECXPST_U_ECXPLOC_U
-        S ECODE1=ECODE1_U_U_ECXMST_U_ECXENRL_U_ECXSTATE_U
-        S ECODE1=ECODE1_ECXCNTY_U_ECASPR_U_ECCLAS2_U_U_ECXDOM_U
-        S ECODE1=ECODE1_ECXCAT_U_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXPHI_U_ECXPOS_U
-        S ECODE1=ECODE1_ECXOBS_U_ECXENC_U_ECXAOL_U_ECXCNH_U_ECXPDIV_U
-        S ECODE1=ECODE1_ECXHNCI_U_ECXETH_U_ECXRC1_U
-        I ECXLOGIC>2004 S ECODE1=ECODE1_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXNPRFI
-        I ECXLOGIC>2006 S ECODE1=ECODE1_U_ECXERI_U_ECXAO_U_ECXECE_U_ECXHNC_U_ECXMIL_U_ECXIR_U
-        I ECXLOGIC>2007 S ECODE2=ECXOEF_U_ECXOEFDT_U_ECXNPPDC_U_ECXNPPDT_U_ECASNPI_U_ECPTNPI
-        S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,^ECX(ECFILE,EC7,2)=$G(ECODE2),ECRN=ECRN+1
-        S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA
-        I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1
-        Q
-SETUP   ;Set required input for ECXTRAC
-        S ECHEAD="PRO"
-        D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
-        S ECINST=$$PDIV^ECXPUTL
-        Q
-        ;
-        ;**Note: LOCAL and QUE are carry over from protocols set by other
-        ;        routines.
-LOCAL   ;to extract nightly for local use not to be transmitted to TSI
-        ;QUEUE with 1D frequency
-        D SETUP,^ECXTLOCL,^ECXKILL Q
-        ;
-QUE     ; entry point for the background requeuing handled by ECXTAUTO
-        D SETUP,QUE^ECXTAUTO,^ECXKILL Q
+ECXPRO ;ALB/GTS - Prosthetics Extract for DSS ; 11/2/06 8:56am
+ ;;3.0;DSS EXTRACTS;**9,13,15,21,24,33,39,46,71,92**;Dec 22, 1997;Build 30
+BEG ;entry point from option
+ D SETUP I ECFILE="" Q
+ D:+ECINST>0 ^ECXTRAC D ^ECXKILL
+ Q
+ ;
+START ;start package specific extract
+ ;
+ ; Input
+ ;  ECSD1   - FM formatted Beginning Date (Set by ECXTRAC)
+ ;  ECED    - FM formatted End Date (Set by ECXTRAC)
+ ;  ECSDN   - Externally formatted Start Date (Set by ECXTRAC)
+ ;  ECEDN   - Externally formatted End Date (Set by ECXTRAC)
+ ;  EC      - IEN from file #727 (Set by ECXTRAC)
+ ;  ECXYM   - Year and Month of extract (YYYYMM)
+ ;  ECXINST - IEN for division in file #4
+ ;  ECINST  - Station number of selected division
+ ;
+ N ECXLNE,ECXCT,ECXDACT,ECX0,ECXLB,ECXED1,ECINSTSV,ECXLNSTR,ECXP
+ N DIC,DR,DA,DIQ,CPTCODE,ECXNPRFI
+ D ECXBUL^ECXPRO2(.ECXLNE,ECSDN,ECEDN,EC)
+ S QFLG=0,ECXLNSTR=ECXLNE,ECXED1=ECED+.9999,ECXCT=ECSD1
+ F  S ECXCT=$O(^RMPR(660,"CT",ECXCT)) Q:(ECXCT>ECXED1)!('ECXCT)!(QFLG=1)  D
+ .S ECXDACT=0
+ .F  S ECXDACT=$O(^RMPR(660,"CT",ECXCT,ECXDACT)) Q:('ECXDACT)!(QFLG=1)  D
+ ..;* initialize variables
+ ..S (ECXDFN,ECXPNM,ECXSSN,ECXSEX,ECXSTAT,ECXDATE,ECXTYPE,ECXSRCE)=""
+ ..S (ECXHCPCS,ECXPHCPC,ECXRQST,ECXRCST,ECXFORM,ECXCTAMT,ECXLLC)=""
+ ..S (ECXLMC,ECXGRPR,ECXBILST,ECXQTY,ECXFELOC,ECXFEKEY,ECXA)=""
+ ..S (ECPTTM,ECPTPR,ECXAST,ECXRST,ECXEST,ECXELIG,ECXVET,ECXZIP)=""
+ ..S (ECXDOB,ECXDSSD,ECXICD9,ECXAOL,ECXHNCI,ECXETH,ECXRC1,ECXMST)=""
+ ..F I=1:1:4 S @("ECXICD9"_I)=""
+ ..Q:'$D(^RMPR(660,ECXDACT,0))
+ ..S ECX0=^RMPR(660,ECXDACT,0),ECXLB=$G(^RMPR(660,ECXDACT,"LB"))
+ ..K ECXP S DIC="^RMPR(660,",DR=".02;11",DA=ECXDACT,DIQ(0)="EI"
+ ..S DIQ="ECXP" D EN^DIQ1
+ ..S ECXDIV=$$GET1^DIQ(660,ECXDACT,8,"I")
+ ..S ECXDFN=$G(ECXP(660,ECXDACT,.02,"I"))
+ ..S ECXFORM=$G(ECXP(660,ECXDACT,11,"E"))_U_$G(ECXP(660,ECXDACT,11,"I"))
+ ..Q:'$$PATDEM^ECXUTL2(ECXDFN,ECXCT)
+ ..Q:'$$NTEG^ECXPRO1(ECXDFN,.ECXLNE,ECXDACT,ECX0,ECXLB,ECINST,ECXFORM)
+ ..D PROSINFO^ECXPRO1(ECXDACT,ECXLB,ECX0,ECXFORM)
+ ..S CPTCODE=$E(ECXHCPCS,1,5)
+ ..;
+ ..;Get production division ;p-46
+ ..N ECXPDIV S ECXPDIV=$$RADDIV^ECXDEPT(ECXDIV) ;p-46
+ ..;- Observation patient indicator (YES/NO)
+ ..S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS)
+ ..;
+ ..;- CNH status (YES/NO)
+ ..S ECXCNH=$$CNHSTAT^ECXUTL4(ECXDFN)
+ ..;
+ ..;get encounter classifications
+ ..S (ECXAO,ECXECE,ECXHNC,ECXMIL,ECXIR)=""
+ ..S ECXVISIT=$$GET1^DIQ(660,ECXDACT,8.12,"I") I ECXVISIT'="" D
+ ...D VISIT^ECXSCX1(ECXDFN,ECXVISIT,.ECXVIST,.ECXERR) I ECXERR K ECXERR Q
+ ...S ECXAO=$G(ECXVIST("AO")),ECXECE=$G(ECXVIST("PGE"))
+ ...S ECXHNC=$G(ECXVIST("HNC")),ECXMIL=$G(ECXVIST("MST")),ECXIR=$G(ECXVIST("IR"))
+ ..; - Head and Neck Cancer Indicator
+ ..S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN)
+ ..;
+ ..; - set national patient record flag if exist
+ ..D NPRF^ECXUTL5
+ ..;
+ ..;- If no encounter number don't file record
+ ..S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,,) Q:ECXENC=""
+ ..I ECXFORM["-3" F ECXLAB="LAB","ORD" D
+ ...D FEEDINFO^ECXPRO2(ECXSRCE,CPTCODE,ECXTYPE,ECXSTAT2,ECXRQST,ECXRCST,ECXLAB)
+ ...Q:ECXFELOC=""  D FILE
+ ..I ECXFORM'["-3" S ECXLAB="NONL" D
+ ...D FEEDINFO^ECXPRO2(ECXSRCE,CPTCODE,ECXTYPE,ECXSTAT2,ECXRQST,ECXRCST,ECXLAB)
+ ...Q:ECXFELOC=""  D FILE
+ ;* Send the Exception message
+ I ECXLNSTR<ECXLNE DO
+ .K XMY S XMY("G.DSS-"_ECGRP_"@"_^XMB("NETNAME"))=""
+ .S XMDUZ=.5
+ .S XMSUB=ECINST_" - Prosthetics DSS Exception Message",XMN=0
+ .S XMTEXT="^TMP(""ECX-PRO EXC"",$J,"
+ .D ^XMD
+ K ^TMP("ECX-PRO EXC",$J),XMDUZ,XMSUB,XMTEXT,XMY
+ Q
+ ;
+FILE ;file extract record
+ ;node0
+ ;facility^dfn (ECXDFN)^ssn (ECXSSN)^name (ECXPNM)^in/out (ECXA)^
+ ;day^feeder location^
+ ;feeder key^qty^pc team^pc provider^hcpcs^icd9 (ECXICD9)^
+ ;icd9-1 (ECXICD91)^icd9-2 (ECXICD92)^icd9-3 (ECXICD93)^
+ ;icd9-4 (ECXICD94)^agent orange^radiation^env contam^eligibility^
+ ;cost^lab labor cost^lab matl cost^billing status^
+ ;vet^transacton type^req station^rec station^file#661.1 ien
+ ;node1
+ ;zip^dob^sex^amis grouper^pc prov npi^mpi^dss dept ECXDSSD^
+ ;pc prov person class^race^pow status^pow loc^
+ ;sharing agree payor^sharing agree ins^mst status^
+ ;enroll loc^state^county^assoc pc provider^
+ ;assoc pc prov person class^assoc pc prov npi
+ ;dom (ECXDOM)^purple heart indicator (ECXPHI)^
+ ;enrollment Category (ECXCAT)^enrollment status (ECXSTAT)^
+ ;enrollment priority (ECXPRIOR)^purple heart ind (ECXPHI)^
+ ;period of serv (ECXPOS)^observ pat ind (ECXOBS)^encounter num (ECXENC)^
+ ;ao loc (ECXAOL)^CNH status (ECXCNH)^production division ECXPDIV^
+ ;head & neck canc. ind. (ECXHNCI)^ethnicity (ECXETH)^race1 (ECXRC1)^
+ ;^enrollment priority (ECXPRIOR)_enrollment sub-
+ ;group (ECXSBGRP)^user enrollee (ECXUESTA)^patient type ECXPTYPE
+ ;^combat vet elig ECXCVE^combat vet elig end date ECXCVEDT^enc cv
+ ;eligible ECXCVENC^national patient record flag ECXNPRFI^
+ ;emergency response indicator(FEMA) ECXERI^agent orange indicator ECXAO
+ ;^environ contam ECXECE^head/neck cancer ECXHNC^encntr mst ECXMIL^
+ ;radiation ECXIR
+ N DA,DIK
+ S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1
+ S ECODE=EC7_U_EC23_U_ECINST_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U
+ S ECODE=ECODE_$$ECXDATE^ECXUTL(ECXDATE,ECXYM)_U_ECXFELOC_U
+ S ECODE=ECODE_ECXFEKEY_U_ECXQTY_U_ECPTTM_U_ECPTPR_U_ECXHCPCS_U
+ S ECODE=ECODE_ECXICD9_U_ECXICD91_U_ECXICD92_U_ECXICD93_U_ECXICD94_U
+ S ECODE=ECODE_ECXAST_U_ECXRST_U_ECXEST_U_ECXELIG_U_ECXCTAMT_U_ECXLLC_U
+ S ECODE=ECODE_ECXLMC_U_ECXBILST_U_ECXVET_U_ECXTYPE_U_ECXRQST_U_ECXRCST_U
+ S ECODE=ECODE_ECXPHCPC_U
+ S ECODE1=ECXZIP_U_ECXDOB_U_ECXSEX_U_ECXGRPR_U_ECPTNPI_U_ECXMPI_U
+ S ECODE1=ECODE1_ECXDSSD_U_ECCLAS_U_ECXRACE_U_ECXPST_U_ECXPLOC_U
+ S ECODE1=ECODE1_U_U_ECXMST_U_ECXENRL_U_ECXSTATE_U
+ S ECODE1=ECODE1_ECXCNTY_U_ECASPR_U_ECCLAS2_U_ECASNPI_U_ECXDOM_U
+ S ECODE1=ECODE1_ECXCAT_U_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXPHI_U_ECXPOS_U
+ S ECODE1=ECODE1_ECXOBS_U_ECXENC_U_ECXAOL_U_ECXCNH_U_ECXPDIV_U
+ S ECODE1=ECODE1_ECXHNCI_U_ECXETH_U_ECXRC1_U
+ I ECXLOGIC>2004 S ECODE1=ECODE1_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXNPRFI
+ I ECXLOGIC>2006 S ECODE1=ECODE1_U_ECXERI_U_ECXAO_U_ECXECE_U_ECXHNC_U_ECXMIL_U_ECXIR
+ S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,ECRN=ECRN+1
+ S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA
+ I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1
+ Q
+SETUP ;Set required input for ECXTRAC
+ S ECHEAD="PRO"
+ D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
+ S ECINST=$$PDIV^ECXPUTL
+ Q
+ ;
+ ;**Note: LOCAL and QUE are carry over from protocols set by other
+ ;        routines.
+LOCAL ;to extract nightly for local use not to be transmitted to TSI
+ ;QUEUE with 1D frequency
+ D SETUP,^ECXTLOCL,^ECXKILL Q
+ ;
+QUE ; entry point for the background requeuing handled by ECXTAUTO
+ D SETUP,QUE^ECXTAUTO,^ECXKILL Q

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXPRO1.m

@@ -1 @@
-ECXPRO1 ;ALB/GTS - Prosthetics Extract for DSS (Continued) ; 11/8/07 8:02am
-        ;;3.0;DSS EXTRACTS;**9,11,13,15,21,24,33,37,39,100,105**;Dec 22, 1997;Build 70
-        ;
-NTEG(ECXDFN,ECXLNE,ECXPIEN,ECXN0,ECXNLB,ECINST,ECXFORM) ;** Check for required fields
-        ;   Input
-        ;    ECXDFN   - ien in file #2
-        ;    ECXLNE   - line number variable (passed by reference)
-        ;    ECXPIEN  - IEN for the Prosthetics record
-        ;    ECXN0    - zero node of the Prosthetics record
-        ;    ECXNLB   - LB node of the Prosthetics record
-        ;    ECINST   - station number being extracted
-        ;    ECXFORM  - Form Requested On
-        ;   Output (to be KILLed by calling routine)
-        ;    ^TMP("ECX-PRO EXC",$J) - Array for the exception message       
-        ;    ECXLNE                 - The number of the next line in the msg
-        ;    ECXSTAT2               - Patient Station Number
-        ;    ECXDATE                - Delivery Date of Prosthesis
-        ;    ECXTYPE                - Type of Transaction work performed
-        ;    ECXSRCE                - Source of prosthesis
-        ;    ECXHCPCS               - CPT/HCPCS code for prosthesis
-        ;    ECXRQST                - Requesting Station
-        ;    ECXRCST                - Receiving Station
-        ;    ECXPHCPC               - PSAS HCPCS code; if 'unknown', then use CPT/HCPCS code 
-        ;    ECXNPPDC               - NPPD code for repairs or new issues
-        ;   Output (KILLed by NTEG)
-        ;    ECXMISS                - 1 indicates missing information
-        ;    ECXGOOD                - 0 indicates record should not be extracted
-        ;
-        N ECXGOOD,ECXMISS
-        S (ECXRCST,ECXRQST,ECXNPPDC)="",ECXGOOD=1,ECXSTAT2=$P(ECXN0,U,10)
-        I ECXSTAT2]"" D
-        .K ECXDIC
-        .S DA=ECXSTAT2,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99"
-        .D EN^DIQ1 S ECXSTAT2=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC
-        .S:(ECINST'=$E(ECXSTAT2,1,3)) ECXGOOD=0 ;*Screen for incorrect Station
-        ;
-        ;** Screen out records
-        S:($P(ECXN0,U,17)'="") ECXGOOD=0 ;*SHIP/DEL is not NULL
-        S:($P(ECXN0,U,26)'="") ECXGOOD=0 ;*PICKUP/DEL is not NULL
-        S:(+($P($G(^RMPR(660,ECXPIEN,"AM")),U,2))=1) ECXGOOD=0 ;*NO ADMIN CT=1
-        S:(($P(ECXN0,U,15))'="") ECXGOOD=0 ;*HISTORICAL DATA is not NULL
-        ;
-        S ECXDATE=$P(ECXN0,U,12),ECXTYPE=$P(ECXN0,U,4),ECXSRCE=$P(ECXN0,U,14)
-        S ECXHCPCS=$P($G(^ICPT(+$P(ECXN0,U,22),0)),U,1),ECXCMOD=""
-        S ECXHCPCS=$$CPT^ECXUTL3(ECXHCPCS,ECXCMOD)
-        ;get psas hcpcs code from file #661.1
-        S ECXPHCPC=$P($G(^RMPR(660,ECXPIEN,1)),U,4) D
-        .;get nppd code for repairs and new issues 10 characters in length.
-        .I "X5"[ECXTYPE S ECXNPPDC=$TR($$GET1^DIQ(661.1,ECXPHCPC_",",5)," ","_")
-        .I "IR"[ECXTYPE S ECXNPPDC=$TR($$GET1^DIQ(661.1,ECXPHCPC_",",6)," ","_")
-        .I +ECXPHCPC S ECXPHCPC=$E($P($G(^RMPR(661.1,ECXPHCPC,0)),U,1),1,5)
-        .I ECXPHCPC="UNKNOWN" S ECXPHCPC=$E(ECXHCPCS,1,5)
-        ;
-        ;* Get Requesting Station Number
-        I ECXFORM["-3" D
-        .S ECXRQST=$P(ECXNLB,U,1)
-        .I ECXRQST]"" D
-        ..S DA=ECXRQST,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99"
-        ..D EN^DIQ1 S ECXRQST=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC
-        S:(ECXFORM'["-3") ECXRQST=""
-        ;
-        ;* Screen out records
-        S:(+$P(ECXFORM,U,2)=13) ECXGOOD=0 ;*FORM REQUESTED ON = 13
-        ;
-        ;* Get Receiving Station Number
-        I ECXFORM["-3" D
-        .S ECXRCST=$P(ECXNLB,U,4)
-        .I ECXRCST]"" D
-        ..S DA=ECXRCST,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99"
-        ..D EN^DIQ1 S ECXRCST=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC
-        S:(ECXFORM'["-3") ECXRCST=""
-        ;
-        ;** Check for integrity and set up the problem variable if right DIV
-        I ECXGOOD D CHK
-        Q ECXGOOD
-        ;
-CHK     ;*Check variables
-        ; Input
-        ;  Variables set in and Output from NTEG^ECXPRO1
-        ; Output
-        ;  ^TMP("ECX-PRO EXC",$J,   - Global of records with integrity problems
-        ;
-        S ECXMISS=""
-        I ECXSTAT2']"" S ECXMISS=ECXMISS_"1"
-        S ECXMISS=ECXMISS_U
-        I ECXDFN=0 S ECXMISS=ECXMISS_"1"
-        S ECXMISS=ECXMISS_U
-        ;I ECXSSN']"" S ECXMISS=ECXMISS_"1"
-        S ECXMISS=ECXMISS_U
-        ;I ECXNA="    " S ECXMISS=ECXMISS_"1"
-        S ECXMISS=ECXMISS_U
-        I ECXDATE']"" S ECXMISS=ECXMISS_"1"
-        S ECXMISS=ECXMISS_U
-        I ECXTYPE']"" S ECXMISS=ECXMISS_"1"
-        S ECXMISS=ECXMISS_U
-        I ECXSRCE']"" S ECXMISS=ECXMISS_"1"
-        S ECXMISS=ECXMISS_U
-        I ECXHCPCS']"" S ECXMISS=ECXMISS_"1"
-        S ECXMISS=ECXMISS_U
-        I ECXFORM["-3" D
-        .I ECXRQST']"" S ECXMISS=ECXMISS_"1"
-        S ECXMISS=ECXMISS_U
-        I ECXFORM']"" S ECXMISS=ECXMISS_"1"
-        S ECXMISS=ECXMISS_U
-        I ECXFORM["-3" D
-        .I ECXRCST']"" S ECXMISS=ECXMISS_"1"
-        I ECXMISS'="^^^^^^^^^^" D
-        .S ECXGOOD=0
-        .D ECXMISLN^ECXPRO2(ECXMISS,.ECXLNE,ECXPIEN)
-        Q
-        ;
-PROSINFO(ECXDA,ECXLB,ECX0,ECXFORM)      ;*Get Prosthetics Information
-        ;
-        ;  Input
-        ;    ECDA    - The IEN for the Prosthetics record
-        ;    ECX0    - The zero node of the Prosthetics record
-        ;    ECXLB   - The LB node of the Prosthetics record
-        ;    ECXFORM - The Form Requested On (to determine Lab transactions)
-        ;
-        ;  Output (to be KILLed by calling routine)
-        ;    ECXCTAMT   - The Cost of Transaction
-        ;    ECXLLC     - The Lab Labor Cost
-        ;    ECXLMC     - The Lab Material Cost
-        ;    ECXGRPR    - The AMIS Grouper number
-        ;    ECXBILST   - The Billing Status
-        ;    ECXQTY     - The Quantity
-        ;
-        S (ECXLLC,ECXLMC,ECXCTAMT)="",ECXBILST=$P($G(^RMPR(660,ECXDA,"AM")),U,3)
-        S ECXQTY=$P(ECX0,U,7)
-        S:(+ECXQTY=0) ECXQTY=1
-        ;
-        ;- Set Quantity field to 8 chars (right-justified & padded w/zeros)
-        S ECXQTY=$$RJ^XLFSTR(ECXQTY,8,0)
-        S ECXGRPR=$P($G(^RMPR(660,ECXDA,"AMS")),U,1),ECXCTAMT=$P(ECX0,U,16)
-        I ECXFORM["-3" D
-        .S ECXCTAMT=$P(ECXLB,U,9),ECXLLC=$P(ECXLB,U,7),ECXLMC=$P(ECXLB,U,8)
-        ;
-        ;- If Stock Issue or Inventory Issue, Cost of Transaction=0
-        I $P(ECXFORM,U,2)=11!($P(ECXFORM,U,2)=12) S ECXCTAMT=0
-        S:ECXCTAMT="" ECXCTAMT=0 S:ECXCTAMT>999999 ECXCTAMT=999999
-        S:ECXLLC="" ECXLLC=0 S:ECXLLC>999999 ECXLLC=999999
-        S:ECXLMC="" ECXLMC=0 S:ECXLMC>999999 ECXLMC=999999
-        ;
-        ;- Round to next dollar amount
-        I (ECXCTAMT#1)>.50 S ECXCTAMT=(ECXCTAMT+1)\1
-        I (ECXLLC#1)>.50 S ECXLLC=(ECXLLC+1)\1
-        I (ECXLMC#1)>.50 S ECXLMC=(ECXLMC+1)\1
-        Q
+ECXPRO1 ;ALB/GTS - Prosthetics Extract for DSS (Continued) ; DEC 15, 2006
+ ;;3.0;DSS EXTRACTS;**9,11,13,15,21,24,33,37,39,100**;Dec 22, 1997;Build 2
+ ;
+NTEG(ECXDFN,ECXLNE,ECXPIEN,ECXN0,ECXNLB,ECINST,ECXFORM) ;** Check for required fields
+ ;   Input
+ ;    ECXDFN   - ien in file #2
+ ;    ECXLNE   - line number variable (passed by reference)
+ ;    ECXPIEN  - IEN for the Prosthetics record
+ ;    ECXN0    - zero node of the Prosthetics record
+ ;    ECXNLB   - LB node of the Prosthetics record
+ ;    ECINST   - station number being extracted
+ ;    ECXFORM  - Form Requested On
+ ;   Output (to be KILLed by calling routine)
+ ;    ^TMP("ECX-PRO EXC",$J) - Array for the exception message       
+ ;    ECXLNE                 - The number of the next line in the msg
+ ;    ECXSTAT2               - Patient Station Number
+ ;    ECXDATE                - Delivery Date of Prosthesis
+ ;    ECXTYPE                - Type of Transaction work performed
+ ;    ECXSRCE                - Source of prosthesis
+ ;    ECXHCPCS               - CPT/HCPCS code for prosthesis
+ ;    ECXRQST                - Requesting Station
+ ;    ECXRCST                - Receiving Station
+ ;    ECXPHCPC               - PSAS HCPCS code; if 'unknown', then use CPT/HCPCS code 
+ ;   Output (KILLed by NTEG)
+ ;    ECXMISS                - 1 indicates missing information
+ ;    ECXGOOD                - 0 indicates record should not be extracted
+ ;
+ N ECXGOOD,ECXMISS
+ S (ECXRCST,ECXRQST)="",ECXGOOD=1,ECXSTAT2=$P(ECXN0,U,10)
+ I ECXSTAT2]"" D
+ .K ECXDIC
+ .S DA=ECXSTAT2,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99"
+ .D EN^DIQ1 S ECXSTAT2=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC
+ .S:(ECINST'=$E(ECXSTAT2,1,3)) ECXGOOD=0 ;*Screen for incorrect Station
+ ;
+ ;** Screen out records
+ S:($P(ECXN0,U,17)'="") ECXGOOD=0 ;*SHIP/DEL is not NULL
+ S:($P(ECXN0,U,26)'="") ECXGOOD=0 ;*PICKUP/DEL is not NULL
+ S:(+($P($G(^RMPR(660,ECXPIEN,"AM")),U,2))=1) ECXGOOD=0 ;*NO ADMIN CT=1
+ S:(($P(ECXN0,U,15))'="") ECXGOOD=0 ;*HISTORICAL DATA is not NULL
+ ;
+ S ECXDATE=$P(ECXN0,U,12),ECXTYPE=$P(ECXN0,U,4),ECXSRCE=$P(ECXN0,U,14)
+ S ECXHCPCS=$P($G(^ICPT(+$P(ECXN0,U,22),0)),U,1),ECXCMOD=""
+ S ECXHCPCS=$$CPT^ECXUTL3(ECXHCPCS,ECXCMOD)
+ ;get psas hcpcs code from file #661.1
+ S ECXPHCPC=$P($G(^RMPR(660,ECXPIEN,1)),U,4) D
+ .;I +ECXPHCPC S ECXPHCPC=$P($G(^RMPR(661.1,ECXPHCPC,0)),U,1)
+ .I +ECXPHCPC S ECXPHCPC=$E($P($G(^RMPR(661.1,ECXPHCPC,0)),U,1),1,5)
+ .I ECXPHCPC="UNKNOWN" S ECXPHCPC=$E(ECXHCPCS,1,5)
+ ;
+ ;* Get Requesting Station Number
+ I ECXFORM["-3" D
+ .S ECXRQST=$P(ECXNLB,U,1)
+ .I ECXRQST]"" D
+ ..S DA=ECXRQST,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99"
+ ..D EN^DIQ1 S ECXRQST=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC
+ S:(ECXFORM'["-3") ECXRQST=""
+ ;
+ ;* Screen out records
+ S:(+$P(ECXFORM,U,2)=13) ECXGOOD=0 ;*FORM REQUESTED ON = 13
+ ;
+ ;* Get Receiving Station Number
+ I ECXFORM["-3" D
+ .S ECXRCST=$P(ECXNLB,U,4)
+ .I ECXRCST]"" D
+ ..S DA=ECXRCST,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99"
+ ..D EN^DIQ1 S ECXRCST=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC
+ S:(ECXFORM'["-3") ECXRCST=""
+ ;
+ ;** Check for integrity and set up the problem variable if right DIV
+ I ECXGOOD D CHK
+ Q ECXGOOD
+ ;
+CHK ;*Check variables
+ ; Input
+ ;  Variables set in and Output from NTEG^ECXPRO1
+ ; Output
+ ;  ^TMP("ECX-PRO EXC",$J,   - Global of records with integrity problems
+ ;
+ S ECXMISS=""
+ I ECXSTAT2']"" S ECXMISS=ECXMISS_"1"
+ S ECXMISS=ECXMISS_U
+ I ECXDFN=0 S ECXMISS=ECXMISS_"1"
+ S ECXMISS=ECXMISS_U
+ ;I ECXSSN']"" S ECXMISS=ECXMISS_"1"
+ S ECXMISS=ECXMISS_U
+ ;I ECXNA="    " S ECXMISS=ECXMISS_"1"
+ S ECXMISS=ECXMISS_U
+ I ECXDATE']"" S ECXMISS=ECXMISS_"1"
+ S ECXMISS=ECXMISS_U
+ I ECXTYPE']"" S ECXMISS=ECXMISS_"1"
+ S ECXMISS=ECXMISS_U
+ I ECXSRCE']"" S ECXMISS=ECXMISS_"1"
+ S ECXMISS=ECXMISS_U
+ I ECXHCPCS']"" S ECXMISS=ECXMISS_"1"
+ S ECXMISS=ECXMISS_U
+ I ECXFORM["-3" D
+ .I ECXRQST']"" S ECXMISS=ECXMISS_"1"
+ S ECXMISS=ECXMISS_U
+ I ECXFORM']"" S ECXMISS=ECXMISS_"1"
+ S ECXMISS=ECXMISS_U
+ I ECXFORM["-3" D
+ .I ECXRCST']"" S ECXMISS=ECXMISS_"1"
+ I ECXMISS'="^^^^^^^^^^" D
+ .S ECXGOOD=0
+ .D ECXMISLN^ECXPRO2(ECXMISS,.ECXLNE,ECXPIEN)
+ Q
+ ;
+PROSINFO(ECXDA,ECXLB,ECX0,ECXFORM) ;*Get Prosthetics Information
+ ;
+ ;  Input
+ ;    ECDA    - The IEN for the Prosthetics record
+ ;    ECX0    - The zero node of the Prosthetics record
+ ;    ECXLB   - The LB node of the Prosthetics record
+ ;    ECXFORM - The Form Requested On (to determine Lab transactions)
+ ;
+ ;  Output (to be KILLed by calling routine)
+ ;    ECXCTAMT   - The Cost of Transaction
+ ;    ECXLLC     - The Lab Labor Cost
+ ;    ECXLMC     - The Lab Material Cost
+ ;    ECXGRPR    - The AMIS Grouper number
+ ;    ECXBILST   - The Billing Status
+ ;    ECXQTY     - The Quantity
+ ;
+ S (ECXLLC,ECXLMC,ECXCTAMT)="",ECXBILST=$P($G(^RMPR(660,ECXDA,"AM")),U,3)
+ S ECXQTY=$P(ECX0,U,7)
+ S:(+ECXQTY=0) ECXQTY=1
+ ;
+ ;- Set Quantity field to 8 chars (right-justified & padded w/zeros)
+ S ECXQTY=$$RJ^XLFSTR(ECXQTY,8,0)
+ S ECXGRPR=$P($G(^RMPR(660,ECXDA,"AMS")),U,1),ECXCTAMT=$P(ECX0,U,16)
+ I ECXFORM["-3" D
+ .S ECXCTAMT=$P(ECXLB,U,9),ECXLLC=$P(ECXLB,U,7),ECXLMC=$P(ECXLB,U,8)
+ ;
+ ;- If Stock Issue or Inventory Issue, Cost of Transaction=0
+ I $P(ECXFORM,U,2)=11!($P(ECXFORM,U,2)=12) S ECXCTAMT=0
+ S:ECXCTAMT="" ECXCTAMT=0 S:ECXCTAMT>999999 ECXCTAMT=999999
+ S:ECXLLC="" ECXLLC=0 S:ECXLLC>999999 ECXLLC=999999
+ S:ECXLMC="" ECXLMC=0 S:ECXLMC>999999 ECXLMC=999999
+ ;
+ ;- Round to next dollar amount
+ I (ECXCTAMT#1)>.50 S ECXCTAMT=(ECXCTAMT+1)\1
+ I (ECXLLC#1)>.50 S ECXLLC=(ECXLLC+1)\1
+ I (ECXLMC#1)>.50 S ECXLMC=(ECXLMC+1)\1
+ Q

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXPURG.m

@@ -1 @@
-ECXPURG ;BIR/CML-Driver for Purge of DSS Data from Local Extract & Holding Files ; 4/17/07 2:35pm
-        ;;3.0;DSS EXTRACTS;**9,24,33,35,49,102**;Dec 22, 1997;Build 17
-EN      ;entry point from option
-        W @IOF,!!,"This option will allow you to purge:"
-        W !,"1. individual or a range of DSS extracts, or"
-        W !,"2. data that resides in the ""holding files"" for the IVP and UDP extracts."
-        W !,"3. data that resides in the ""holding file"" for the VBECS extract"
-        W !!,"Care must be taken for several reasons:"
-        W !!,"-  You can purge ANY existing extract.  This includes transmitted and non-"
-        W !,"   transmitted extracts as well as extracts that did not run to completion"
-        W !,"   due to errors or system problems."
-        W !,"-  Choosing a range of extracts (or a broad date range for the ""holding"
-        W !,"   files"") could mean an excessively large number of records and be very"
-        W !,"   CPU intensive.  Please be sure to queue this purge for off-hours and"
-        W !,"   limit the number of extracts to be purged per a single queued session."
-        W !,"-  The IVP, UDP and VBECS ""holding"" files are intermediate files that"
-        W !,"   are populated ""realtime"" by inpatient pharmacy and VBECS activity. These"
-        W !,"   files are then used to generate the IVP, UDP and VBECS extracts and CANNOT be"
-        W !,"   recreated. Once they are purged for a date range, extracts can no longer be"
-        W !,"   generated for that time period."
-        ;
-        K DIR W !
-        S DIR(0)="SAM^E:Extract Files;I:IVP Holding File;U:UDP Holding File;V:VBECS Holding File"
-        S DIR("A")="Purge (E)xtract files, (I)VP data, (U)DP data or (V)BECS data? "
-        D ^DIR K DIR G:$D(DIRUT) QUIT S ECY=Y
-        I ECY="E" D ^ECXPURG1 I $D(ECLOC) S ZTSAVE("ECLOC(")="",ZTIO="",ZTRTN="PUR1^ECXPURG",ZTDESC="DSS - Purge of Extract Files" D QUE
-        I ECY="I" D DATES^ECXPURG1 I $D(ECBDT)&($D(ECEDT)) S (ZTSAVE("ECBDT"),ZTSAVE("ECEDT"))="",ZTIO="",ZTRTN="PUR2^ECXPURG",ZTDESC="DSS - Purge of IVP Holding File" D QUE
-        I ECY="U" D DATES^ECXPURG1 I $D(ECBDT)&($D(ECEDT)) S (ZTSAVE("ECBDT"),ZTSAVE("ECEDT"))="",ZTIO="",ZTRTN="PUR3^ECXPURG",ZTDESC="DSS - Purge of UDP Holding File" D QUE
-        I ECY="V" D DATES^ECXPURG1 I $D(ECBDT)&($D(ECEDT)) S (ZTSAVE("ECBDT"),ZTSAVE("ECEDT"))="",ZTIO="",ZTRTN="PUR4^ECXPURG",ZTDESC="DSS - Purge of VBECS Holding File" D QUE
-QUIT    ;
-        K %X,%Y,EC,ECBDT,ECDATE,ECDT,ECEDT,ECEX,ECFR,ECLOC,ECRC,ECTO,ECTRN,ECTYP,ECY,HDT,HI,JJ,LN,LO,PG,QFLG,SS,X,Y,ZTSK
-        K ECXDIV
-        S:$D(ZTQUEUED) ZTREQ="@"
-        Q
-QUE     W $C(7),$C(7),!!?3,"<<This purge should be queued to run during non-peak hours.>>",!
-        D ^%ZTLOAD
-        I $D(ZTSK) W !,"Request queued as Task #",ZTSK,".",!
-        Q
-        ;
-PUR1    ; entry point for queued purge job of extract files
-        S ECDA=0 F  S ECDA=$O(ECLOC(ECDA)) Q:'ECDA  D
-        .S ECFILE=^ECX(727,ECDA,"FILE"),ECJ=0
-        .I ECFILE=727.827 D
-        ..S DA(1)=1
-        ..S DA=$O(^ECX(728,DA(1),"CBOC","B",ECDA,0))
-        ..S DIK="^ECX(728,"_DA(1)_","_"""CBOC"""_","
-        ..I DA'="" D ^DIK K DIK,DA
-        .F  S ECJ=$O(^ECX(ECFILE,"AC",ECDA,ECJ)) Q:'ECJ  D
-        ..S DIK="^ECX("_ECFILE_",",DA=ECJ D ^DIK K DIK,DA
-        .I ECFILE=727.816 S ECFILE=727.818,ECJ=0 D
-        ..F  S ECJ=$O(^ECX(ECFILE,"AC",ECDA,ECJ)) Q:'ECJ  D
-        ...S DIK="^ECX("_ECFILE_",",DA=ECJ D ^DIK K DIK,DA
-        .S ^ECX(727,ECDA,"PURG")=DT
-        D QUIT
-        Q
-        ;
-PUR2    ; entry point for queued purge job of IVP holding file (#728.113)
-        F ECDT=ECBDT-1:0 S ECDT=$O(^ECX(728.113,"A",ECDT)) Q:'ECDT  Q:ECDT>ECEDT  S ECPT=0 F  S ECPT=$O(^ECX(728.113,"A",ECDT,ECPT)) Q:'ECPT  D
-        .S ECOR=0 F  S ECOR=$O(^ECX(728.113,"A",ECDT,ECPT,ECOR)) Q:'ECOR  D
-        ..S ECREC=0 F  S ECREC=$O(^ECX(728.113,"A",ECDT,ECPT,ECOR,ECREC)) Q:'ECREC  D
-        ...S DIK="^ECX(728.113,",DA=ECREC D ^DIK K DIK,DA
-        D QUIT
-        Q
-        ;
-PUR3    ; entry point for queued purge job of UDP holding file (#728.904)
-        F ECDT=ECBDT-1:0 S ECDT=$O(^ECX(728.904,"A",ECDT)) Q:'ECDT  Q:ECDT>ECEDT  D
-        .S ECREC=0 F  S ECREC=$O(^ECX(728.904,"A",ECDT,ECREC)) Q:'ECREC  D
-        ..S DIK="^ECX(728.904,",DA=ECREC D ^DIK K DIK,DA
-        D QUIT
-        Q
-        ;
-PUR4    ; entry point for queued purge job of VBECS holding file (#6002.03)
-        N ECDT,ECREC,DIK,DA
-        S ECDT=ECBDT-1,ECEDT=ECEDT+.9
-        F  S ECDT=$O(^VBEC(6002.03,"C",ECDT)) Q:'ECDT!(ECDT>ECEDT)  D
-        .S ECREC=0 F  S ECREC=$O(^VBEC(6002.03,"C",ECDT,ECREC)) Q:'ECREC  D
-        ..S DIK="^VBEC(6002.03,",DA=ECREC D ^DIK K DIK,DA
-        Q
+ECXPURG ;BIR/CML-Driver for Purge of DSS Data from Local Extract & Holding Files ; [ 12/03/96  5:19 PM ]
+ ;;3.0;DSS EXTRACTS;**9,24,33,35,49**;Dec 22, 1997
+EN ;entry point from option
+ W @IOF,!!,"This option will allow you to purge:"
+ W !,"1. individual or a range of DSS extracts, or"
+ W !,"2. data that resides in the ""holding files"" for the IVP and UDP extracts."
+ W !!,"Care must be taken for several reasons:"
+ W !!,"-  You can purge ANY existing extract.  This includes transmitted and non-"
+ W !,"   transmitted extracts as well as extracts that did not run to completion"
+ W !,"   due to errors or system problems."
+ W !,"-  Choosing a range of extracts (or a broad date range for the ""holding"
+ W !,"   files"") could mean an excessively large number of records and be very"
+ W !,"   CPU intensive.  Please be sure to queue this purge for off-hours and"
+ W !,"   limit the number of extracts to be purged per a single queued session."
+ W !,"-  The IVP and UDP ""holding"" files are intermediate files that are"
+ W !,"   populated ""realtime"" by inpatient pharmacy activity.  These files are"
+ W !,"   then used to generate the IVP and UDP extracts and CANNOT be recreated."
+ W !,"   Once they are purged for a date range, extracts can no longer be"
+ W !,"   generated for that time period."
+ ;
+ K DIR W !
+ S DIR(0)="SAM^E:Extract Files;I:IVP Holding File;U:UDP Holding File"
+ S DIR("A")="Purge (E)xtract files, (I)VP data, or (U)DP data? "
+ D ^DIR K DIR G:$D(DIRUT) QUIT S ECY=Y
+ I ECY="E" D ^ECXPURG1 I $D(ECLOC) S ZTSAVE("ECLOC(")="",ZTIO="",ZTRTN="PUR1^ECXPURG",ZTDESC="DSS - Purge of Extract Files" D QUE
+ I ECY="I" D DATES^ECXPURG1 I $D(ECBDT)&($D(ECEDT)) S (ZTSAVE("ECBDT"),ZTSAVE("ECEDT"))="",ZTIO="",ZTRTN="PUR2^ECXPURG",ZTDESC="DSS - Purge of IVP Holding File" D QUE
+ I ECY="U" D DATES^ECXPURG1 I $D(ECBDT)&($D(ECEDT)) S (ZTSAVE("ECBDT"),ZTSAVE("ECEDT"))="",ZTIO="",ZTRTN="PUR3^ECXPURG",ZTDESC="DSS - Purge of UDP Holding File" D QUE
+QUIT ;
+ K %X,%Y,EC,ECBDT,ECDATE,ECDT,ECEDT,ECEX,ECFR,ECLOC,ECRC,ECTO,ECTRN,ECTYP,ECY,HDT,HI,JJ,LN,LO,PG,QFLG,SS,X,Y,ZTSK
+ K ECXDIV
+ S:$D(ZTQUEUED) ZTREQ="@"
+ Q
+QUE W $C(7),$C(7),!!?3,"<<This purge should be queued to run during non-peak hours.>>",!
+ D ^%ZTLOAD
+ I $D(ZTSK) W !,"Request queued as Task #",ZTSK,".",!
+ Q
+ ;
+PUR1 ; entry point for queued purge job of extract files
+ S ECDA=0 F  S ECDA=$O(ECLOC(ECDA)) Q:'ECDA  D
+ .S ECFILE=^ECX(727,ECDA,"FILE"),ECJ=0
+ .I ECFILE=727.827 D
+ ..S DA(1)=1
+ ..S DA=$O(^ECX(728,DA(1),"CBOC","B",ECDA,0))
+ ..S DIK="^ECX(728,"_DA(1)_","_"""CBOC"""_","
+ ..I DA'="" D ^DIK K DIK,DA
+ .F  S ECJ=$O(^ECX(ECFILE,"AC",ECDA,ECJ)) Q:'ECJ  D
+ ..S DIK="^ECX("_ECFILE_",",DA=ECJ D ^DIK K DIK,DA
+ .I ECFILE=727.816 S ECFILE=727.818,ECJ=0 D
+ ..F  S ECJ=$O(^ECX(ECFILE,"AC",ECDA,ECJ)) Q:'ECJ  D
+ ...S DIK="^ECX("_ECFILE_",",DA=ECJ D ^DIK K DIK,DA
+ .S ^ECX(727,ECDA,"PURG")=DT
+ D QUIT
+ Q
+ ;
+PUR2 ; entry point for queued purge job of IVP holding file (#728.113)
+ F ECDT=ECBDT-1:0 S ECDT=$O(^ECX(728.113,"A",ECDT)) Q:'ECDT  Q:ECDT>ECEDT  S ECPT=0 F  S ECPT=$O(^ECX(728.113,"A",ECDT,ECPT)) Q:'ECPT  D
+ .S ECOR=0 F  S ECOR=$O(^ECX(728.113,"A",ECDT,ECPT,ECOR)) Q:'ECOR  D
+ ..S ECREC=0 F  S ECREC=$O(^ECX(728.113,"A",ECDT,ECPT,ECOR,ECREC)) Q:'ECREC  D
+ ...S DIK="^ECX(728.113,",DA=ECREC D ^DIK K DIK,DA
+ D QUIT
+ Q
+ ;
+PUR3 ; entry point for queued purge job of UDP holding file (#728.904)
+ F ECDT=ECBDT-1:0 S ECDT=$O(^ECX(728.904,"A",ECDT)) Q:'ECDT  Q:ECDT>ECEDT  D
+ .S ECREC=0 F  S ECREC=$O(^ECX(728.904,"A",ECDT,ECREC)) Q:'ECREC  D
+ ..S DIK="^ECX(728.904,",DA=ECREC D ^DIK K DIK,DA
+ D QUIT
+ Q

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXPURG1.m

@@ -1 @@
-ECXPURG1        ;BIR/CML-Purge of DSS Extract Files (CONTINUED) ; 5/27/08 9:26am
-        ;;3.0;DSS EXTRACTS;**2,9,8,24,49,102**;Dec 22, 1997;Build 17
-GET     ;compile list of purgable extracts
-        K HI,LO,ECBDT,ECEDT,ECLOC,^TMP("ECXPURG",$J)
-        S QFLG=1 W !!,"...one moment please"
-        S ECEX=0 F  S ECEX=$O(^ECX(727,ECEX)) Q:'ECEX  I '$G(^ECX(727,ECEX,"PURG")),$D(^ECX(727,ECEX,0)) S EC=^(0) D
-        .S ^TMP("ECXPURG",$J,$P(EC,U,3),ECEX)="",ECLOC(ECEX)=$P(EC,U,3)_U_$P(EC,U,4,5)
-        I '$D(^TMP("ECXPURG",$J)) W !!,"There are no extracts that can be purged at this time." G DONE
-ASK1    ;ask for print
-        W !
-        K DIR S DIR(0)="Y",DIR("A")="Do you want to print a list of extracts that can be purged",DIR("B")="NO"
-        D ^DIR K DIR I $D(DIRUT) K ECLOC G DONE
-        G:'Y ASK2
-        W !!,"The right margin for this report is 80.",!!
-        K ZTSAVE S ZTSAVE("^TMP(""ECXPURG"",$J,")=""
-        D EN^XUTMDEVQ("PRT^ECXPURG1","DSS - Print Purgable Extracts",.ZTSAVE) I 'POP G ASK2
-        W !,"NO DEVICE SELECTED OR REPORT PRINTED!!"
-ASK2    ;ask for extract range
-        ;
-        ;** Check divisions for purging
-        N ECCHK,ECTMP
-        S ECCHK=$$DIV4^XUSER(.ECTMP,DUZ)
-        I 'ECCHK DO
-        .W !,"You do not have any divisions defined in your user set up and can not purge."
-        .S DIR(0)="FAO^1:1",DIR("A")="Hit Return to continue." D ^DIR K DIR,X,Y
-        .K ECLOC
-        ;
-        I 'ECCHK G DONE  ;** (essentially) QUIT out of middle
-        ;
-        W !,"You will not be able to select an extract that is not from your division.",!
-        S LO=$O(ECLOC(0)),HI=$O(ECLOC(" "),-1)
-        S DIR(0)="L^"_LO_":"_HI_"",DIR("A")="Select extracts to be purged"
-        S DIR("?",1)="Choose the number(s) of the extract(s) you wish to purge,",DIR("?")="(e.g. 1-3,17,20 to choose 1 thru 3, 17, and 20)."
-        W ! D ^DIR K DIR I $D(DIRUT) K ECLOC G DONE
-        S JJ=0,Y=","_Y F  S JJ=$O(ECLOC(JJ)) Q:'JJ  S JZ=","_JJ_"," I Y'[JZ K ECLOC(JJ)
-        D CBOCCHK(.ECLOC) I '$D(ECLOC) G GET
-        D DIVCHK(.ECLOC,.ECTMP)
-        I '$D(ECLOC) W !!,"You have not chosen a valid extract number.  Try again." G GET
-ASK3    W !!,"I will purge the following extract(s):"
-        S JJ=0 F  S JJ=$O(ECLOC(JJ)) Q:'JJ  D
-        .W !?5,"#",JJ," - ",$P(ECLOC(JJ),U)
-        .W ?47,$TR($$FMTE^XLFDT($P(ECLOC(JJ),U,2),"5DF")," ","0")," to ",$TR($$FMTE^XLFDT($P(ECLOC(JJ),U,3),"5DF")," ","0")
-        W !! K DIR S DIR(0)="Y",DIR("A")="Is this OK",DIR("B")="NO"
-        S DIR("?",1)="    Enter:"
-        S DIR("?",2)="      ""YES"" if you agree with this list and would like to proceed,"
-        S DIR("?",3)="       ""NO"" if you would like to make a different selection, or"
-        S DIR("?")="        ""^"" to exit option."
-        D ^DIR K DIR I $D(DIRUT) K ECLOC G DONE
-        I 'Y G GET
-        ; at this point, the local array ECLOC( is passed back to ^ECXPURG
-        G DONE
-QUIT    ;
-        I $E(IOST)="C"&('QFLG) S DIR(0)="E" D  D ^DIR K DIR
-        .S SS=22-$Y F JJ=1:1:SS W !
-        W:$E(IOST)'="C" @IOF D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
-DONE    K ^TMP("ECXPURG",$J),ZTSK Q
-PRT     ;print list of extracts
-        S (PG,QFLG)=0,$P(LN,"-",81)="" D NOW^%DTC S Y=$E(%,1,12) X ^DD("DD") S HDT=Y D HDR
-        S ECTYP="" F  S ECTYP=$O(^TMP("ECXPURG",$J,ECTYP)) Q:ECTYP=""  Q:QFLG  D:$Y+4>IOSL HDR Q:QFLG  W !!,ECTYP D
-        .S ECEX=0 F  S ECEX=$O(^TMP("ECXPURG",$J,ECTYP,ECEX)) Q:'ECEX  Q:QFLG  I $D(^ECX(727,ECEX,0)) S EC=^(0) D
-        ..S ECDT=$$FMTE^XLFDT($P(EC,U,2),"D")
-        ..S ECFR=$TR($$FMTE^XLFDT($P(EC,U,4),"5DF")," ","0")
-        ..S ECTO=$TR($$FMTE^XLFDT($P(EC,U,5),"5DF")," ","0")
-        ..S ECRC=$P(EC,U,6) S:ECRC="" ECRC="Incomplete"
-        ..S ECTRN=$$FMTE^XLFDT($G(^ECX(727,ECEX,"TR")),"D")
-        ..S ECXDIV=$P($G(^ECX(727,ECEX,"DIV")),U,1) I ECXDIV D
-        ...K ECXDIC S DA=ECXDIV,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99"
-        ...D EN^DIQ1 S ECXDIV=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC
-        ..D:$Y+3>IOSL HDR Q:QFLG
-        ..W !?1,ECEX,?11,ECDT,?25,ECFR,"-",ECTO,?48,$J(ECRC,9),?60,ECTRN,?75,ECXDIV
-        G QUIT
-HDR     ;HEADER
-        I $E(IOST)="C" S SS=22-$Y F JJ=1:1:SS W !
-        I $E(IOST)="C",PG>0 S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q
-        S PG=PG+1 W:$Y!($E(IOST)="C") @IOF W !,"PURGABLE EXTRACTS",?72,"Page: ",PG,!,"Printed on ",HDT,!
-        W !,"FEEDER SYS",?12,"EXTRACT,",!,"EXTRACT #",?12,"DATE",?33,"FROM-TO",?48,"RECORD CNT",?60,"TRANSMIT DATE",?75,"DIV",!,LN
-        Q
-DATES   ;ask for date range for purge of holding files
-        K HI,LO,ECBDT,ECEDT
-        I ECY="I" D
-        .I '$O(^ECX(728.113,0)) W !!,"You have no data in the IVP holding file (file #728.113) to purge." Q
-        .S LO=$O(^ECX(728.113,"A",0)),HI=$O(^ECX(728.113,"A"," "),-1)
-        I ECY="U" D
-        .I '$O(^ECX(728.904,0)) W !!,"You have no data in the UDP holding file (file #728.904) to purge." Q
-        .S LO=$O(^ECX(728.904,"A",0)),HI=$O(^ECX(728.904,"A"," "),-1)
-        I ECY="V" D
-        .I '$O(^VBEC(6002.03,0)) W !!,"You have no data in the VBECS holding file (file #6002.03) to purge." Q
-        .S LO=$O(^VBEC(6002.03,"C",0)),HI=$O(^VBEC(6002.03,"C"," "),-1)
-        Q:$G(LO)=""
-        W @IOF,!!,"This file currently holds ",$S(ECY="I":"IVP",ECY="U":"UDP",1:"VBECS")," data from <",$$FMTE^XLFDT(LO,"D"),"> to <",$$FMTE^XLFDT(HI,"D"),">."
-        W ! K DIR S DIR(0)="DA^"_LO_":"_HI_":EPX",DIR("A")="Beginning date for purge: " D ^DIR K DIR I $D(DIRUT) K HI,LO Q
-        S ECBDT=+Y
-        K DIR S DIR(0)="DA^"_ECBDT_":"_HI_":EPX",DIR("A")="Ending date for purge: " D ^DIR K DIR I $D(DIRUT) K HI,LO,ECBDT Q
-        S ECEDT=+Y
-ASK4    ; ask to confirm date range
-        W !!,"I will purge the ",$S(ECY="I":"IVP",ECY="U":"UDP",1:"VBECS")," holding file from <",$$FMTE^XLFDT(ECBDT,"D"),"> to <",$$FMTE^XLFDT(ECEDT,"D"),">."
-        W $C(7),$C(7),!!?3,"** REMEMBER - Once this data is purged it CANNOT be recreated. **"
-        W !! K DIR S DIR(0)="Y",DIR("A")="Is this OK",DIR("B")="NO"
-        S DIR("?",1)="    Enter:"
-        S DIR("?",2)="      ""YES"" if you agree with this date range and wish to proceed,"
-        S DIR("?",3)="       ""NO"" if you would like to make a different selection, or"
-        S DIR("?")="        ""^"" to exit option."
-        D ^DIR K DIR I $D(DIRUT) K ECBDT,ECEDT Q 
-        I 'Y G DATES
-        ; at this point, ECBDT and ECEDT are passed back to ^ECXPURG
-        Q
-        ;
-DIVCHK(ECLOC,ECTMP)     ;**Remove extracts from ECLOC that are for user's div.
-        N ECLPDA
-        S ECLPDA=0
-        F  S ECLPDA=$O(ECLOC(ECLPDA)) Q:(+ECLPDA=0)  DO
-        .I '$D(ECTMP($P(^ECX(727,ECLPDA,"DIV"),U,1))) KILL ECLOC(ECLPDA)
-        Q
-CBOCCHK(ECLOC)  ;**Check that CBOC report has been viewed prior to purging
-        N LOOPDA,YYYMMDD
-        S LOOPDA=0
-        F  S LOOPDA=$O(ECLOC(LOOPDA)) Q:(+LOOPDA=0)  D
-        .I ^ECX(727,LOOPDA,"HEAD")="CLI" D
-        ..S DA(1)=1
-        ..S YYYMMDD=$P(^ECX(727,LOOPDA,0),U,4)
-        ..I YYYMMDD>3030930 I '$D(^ECX(728,DA(1),"CBOC","B",LOOPDA)) D
-        ...K DIR S DIR(0)="Y",DIR("A")="The CBOC Activity Report has not been viewed.  Purge anyway",DIR("B")="NO"
-        ...D ^DIR K DIR I 'Y K ECLOC(LOOPDA)
-        Q
+ECXPURG1 ;BIR/CML-Purge of DSS Extract Files (CONTINUED) ; [ 12/05/96  11:58 AM ]
+ ;;3.0;DSS EXTRACTS;**2,9,8,24,49**;Dec 22, 1997
+GET ;compile list of purgable extracts
+ K HI,LO,ECBDT,ECEDT,ECLOC,^TMP("ECXPURG",$J)
+ S QFLG=1 W !!,"...one moment please"
+ S ECEX=0 F  S ECEX=$O(^ECX(727,ECEX)) Q:'ECEX  I '$G(^ECX(727,ECEX,"PURG")),$D(^ECX(727,ECEX,0)) S EC=^(0) D
+ .S ^TMP("ECXPURG",$J,$P(EC,U,3),ECEX)="",ECLOC(ECEX)=$P(EC,U,3)_U_$P(EC,U,4,5)
+ I '$D(^TMP("ECXPURG",$J)) W !!,"There are no extracts that can be purged at this time." G DONE
+ASK1 ;ask for print
+ W !
+ K DIR S DIR(0)="Y",DIR("A")="Do you want to print a list of extracts that can be purged",DIR("B")="NO"
+ D ^DIR K DIR I $D(DIRUT) K ECLOC G DONE
+ G:'Y ASK2
+ W !!,"The right margin for this report is 80.",!!
+ K ZTSAVE S ZTSAVE("^TMP(""ECXPURG"",$J,")=""
+ D EN^XUTMDEVQ("PRT^ECXPURG1","DSS - Print Purgable Extracts",.ZTSAVE) I 'POP G ASK2
+ W !,"NO DEVICE SELECTED OR REPORT PRINTED!!"
+ASK2 ;ask for extract range
+ ;
+ ;** Check divisions for purging
+ N ECCHK,ECTMP
+ S ECCHK=$$DIV4^XUSER(.ECTMP,DUZ)
+ I 'ECCHK DO
+ .W !,"You do not have any divisions defined in your user set up and can not purge."
+ .S DIR(0)="FAO^1:1",DIR("A")="Hit Return to continue." D ^DIR K DIR,X,Y
+ .K ECLOC
+ ;
+ I 'ECCHK G DONE  ;** (essentially) QUIT out of middle
+ ;
+ W !,"You will not be able to select an extract that is not from your division.",!
+ S LO=$O(ECLOC(0)),HI=$O(ECLOC(" "),-1)
+ S DIR(0)="L^"_LO_":"_HI_"",DIR("A")="Select extracts to be purged"
+ S DIR("?",1)="Choose the number(s) of the extract(s) you wish to purge,",DIR("?")="(e.g. 1-3,17,20 to choose 1 thru 3, 17, and 20)."
+ W ! D ^DIR K DIR I $D(DIRUT) K ECLOC G DONE
+ S JJ=0,Y=","_Y F  S JJ=$O(ECLOC(JJ)) Q:'JJ  S JZ=","_JJ_"," I Y'[JZ K ECLOC(JJ)
+ D CBOCCHK(.ECLOC) I '$D(ECLOC) G GET
+ D DIVCHK(.ECLOC,.ECTMP)
+ I '$D(ECLOC) W !!,"You have not chosen a valid extract number.  Try again." G GET
+ASK3 W !!,"I will purge the following extract(s):"
+ S JJ=0 F  S JJ=$O(ECLOC(JJ)) Q:'JJ  D
+ .W !?5,"#",JJ," - ",$P(ECLOC(JJ),U)
+ .W ?47,$TR($$FMTE^XLFDT($P(ECLOC(JJ),U,2),"5DF")," ","0")," to ",$TR($$FMTE^XLFDT($P(ECLOC(JJ),U,3),"5DF")," ","0")
+ W !! K DIR S DIR(0)="Y",DIR("A")="Is this OK",DIR("B")="NO"
+ S DIR("?",1)="    Enter:"
+ S DIR("?",2)="      ""YES"" if you agree with this list and would like to proceed,"
+ S DIR("?",3)="       ""NO"" if you would like to make a different selection, or"
+ S DIR("?")="        ""^"" to exit option."
+ D ^DIR K DIR I $D(DIRUT) K ECLOC G DONE
+ I 'Y G GET
+ ; at this point, the local array ECLOC( is passed back to ^ECXPURG
+ G DONE
+QUIT ;
+ I $E(IOST)="C"&('QFLG) S DIR(0)="E" D  D ^DIR K DIR
+ .S SS=22-$Y F JJ=1:1:SS W !
+ W:$E(IOST)'="C" @IOF D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
+DONE K ^TMP("ECXPURG",$J),ZTSK Q
+PRT ;print list of extracts
+ S (PG,QFLG)=0,$P(LN,"-",81)="" D NOW^%DTC S Y=$E(%,1,12) X ^DD("DD") S HDT=Y D HDR
+ S ECTYP="" F  S ECTYP=$O(^TMP("ECXPURG",$J,ECTYP)) Q:ECTYP=""  Q:QFLG  D:$Y+4>IOSL HDR Q:QFLG  W !!,ECTYP D
+ .S ECEX=0 F  S ECEX=$O(^TMP("ECXPURG",$J,ECTYP,ECEX)) Q:'ECEX  Q:QFLG  I $D(^ECX(727,ECEX,0)) S EC=^(0) D
+ ..S ECDT=$$FMTE^XLFDT($P(EC,U,2),"D")
+ ..S ECFR=$TR($$FMTE^XLFDT($P(EC,U,4),"5DF")," ","0")
+ ..S ECTO=$TR($$FMTE^XLFDT($P(EC,U,5),"5DF")," ","0")
+ ..S ECRC=$P(EC,U,6) S:ECRC="" ECRC="Incomplete"
+ ..S ECTRN=$$FMTE^XLFDT($G(^ECX(727,ECEX,"TR")),"D")
+ ..S ECXDIV=$P($G(^ECX(727,ECEX,"DIV")),U,1) I ECXDIV D
+ ...K ECXDIC S DA=ECXDIV,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99"
+ ...D EN^DIQ1 S ECXDIV=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC
+ ..D:$Y+3>IOSL HDR Q:QFLG
+ ..W !?1,ECEX,?11,ECDT,?25,ECFR,"-",ECTO,?48,$J(ECRC,9),?60,ECTRN,?75,ECXDIV
+ G QUIT
+HDR ;HEADER
+ I $E(IOST)="C" S SS=22-$Y F JJ=1:1:SS W !
+ I $E(IOST)="C",PG>0 S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q
+ S PG=PG+1 W:$Y!($E(IOST)="C") @IOF W !,"PURGABLE EXTRACTS",?72,"Page: ",PG,!,"Printed on ",HDT,!
+ W !,"FEEDER SYS",?12,"EXTRACT,",!,"EXTRACT #",?12,"DATE",?33,"FROM-TO",?48,"RECORD CNT",?60,"TRANSMIT DATE",?75,"DIV",!,LN
+ Q
+DATES ;ask for date range for purge of holding files
+ K HI,LO,ECBDT,ECEDT
+ I ECY="I" D
+ .I '$O(^ECX(728.113,0)) W !!,"You have no data in the IVP holding file (file #728.113) to purge." Q
+ .S LO=$O(^ECX(728.113,"A",0)),HI=$O(^ECX(728.113,"A"," "),-1)
+ I ECY="U" D
+ .I '$O(^ECX(728.904,0)) W !!,"You have no data in the UDP holding file (file #728.904) to purge." Q
+ .S LO=$O(^ECX(728.904,"A",0)),HI=$O(^ECX(728.904,"A"," "),-1)
+ Q:$G(LO)=""
+ W @IOF,!!,"This file currently holds ",$S(ECY="I":"IVP",1:"UDP")," data from <",$$FMTE^XLFDT(LO,"D"),"> to <",$$FMTE^XLFDT(HI,"D"),">."
+ W ! K DIR S DIR(0)="DA^"_LO_":"_HI_":EPX",DIR("A")="Beginning date for purge: " D ^DIR K DIR I $D(DIRUT) K HI,LO Q
+ S ECBDT=+Y
+ K DIR S DIR(0)="DA^"_ECBDT_":"_HI_":EPX",DIR("A")="Ending date for purge: " D ^DIR K DIR I $D(DIRUT) K HI,LO,ECBDT Q
+ S ECEDT=+Y
+ASK4 ; ask to confirm date range
+ W !!,"I will purge the ",$S(ECY="I":"IVP",1:"UDP")," holding file from <",$$FMTE^XLFDT(ECBDT,"D"),"> to <",$$FMTE^XLFDT(ECEDT,"D"),">."
+ W $C(7),$C(7),!!?3,"** REMEMBER - Once this data is purged it CANNOT be recreated. **"
+ W !! K DIR S DIR(0)="Y",DIR("A")="Is this OK",DIR("B")="NO"
+ S DIR("?",1)="    Enter:"
+ S DIR("?",2)="      ""YES"" if you agree with this date range and wish to proceed,"
+ S DIR("?",3)="       ""NO"" if you would like to make a different selection, or"
+ S DIR("?")="        ""^"" to exit option."
+ D ^DIR K DIR I $D(DIRUT) K ECBDT,ECEDT Q 
+ I 'Y G DATES
+ ; at this point, ECBDT and ECEDT are passed back to ^ECXPURG
+ Q
+ ;
+DIVCHK(ECLOC,ECTMP) ;**Remove extracts from ECLOC that are for user's div.
+ N ECLPDA
+ S ECLPDA=0
+ F  S ECLPDA=$O(ECLOC(ECLPDA)) Q:(+ECLPDA=0)  DO
+ .I '$D(ECTMP($P(^ECX(727,ECLPDA,"DIV"),U,1))) KILL ECLOC(ECLPDA)
+ Q
+CBOCCHK(ECLOC) ;**Check that CBOC report has been viewed prior to purging
+ N LOOPDA,YYYMMDD
+ S LOOPDA=0
+ F  S LOOPDA=$O(ECLOC(LOOPDA)) Q:(+LOOPDA=0)  D
+ .I ^ECX(727,LOOPDA,"HEAD")="CLI" D
+ ..S DA(1)=1
+ ..S YYYMMDD=$P(^ECX(727,LOOPDA,0),U,4)
+ ..I YYYMMDD>3030930 I '$D(^ECX(728,DA(1),"CBOC","B",LOOPDA)) D
+ ...K DIR S DIR(0)="Y",DIR("A")="The CBOC Activity Report has not been viewed.  Purge anyway",DIR("B")="NO"
+ ...D ^DIR K DIR I 'Y K ECLOC(LOOPDA)
+ Q

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXQSR.m

@@ -1 @@
-ECXQSR  ;ALB/JAP,BIR/PTD-DSS QUASAR Extract ; 7/31/07 11:19pm
-        ;;3.0;DSS EXTRACTS;**11,8,13,26,24,34,33,35,39,43,46,49,64,71,84,92,106,105**;Dec 22, 1997;Build 70
-BEG     ;entry point from option
-        I '$O(^ACK(509850.8,0)) W !,"You must be using the Quality Audiology & Speech Pathology",!,"Audit & Review (QUASAR) software to run this extract.",!! Q
-        I '$D(^ACK(509850.8,1,"DSS")) W !,"Linkage has not been established between QUASAR and the DSS UNIT file (#724).",!! Q
-        I '$O(^ACK(509850.6,0)) W !,"There is no data in the A&SP CLINIC VISIT file (#509850.6).",!! Q
-        D SETUP I ECFILE="" Q
-        D ^ECXTRAC,^ECXKILL
-        Q
-START   ;entry point from tasked job
-        N ERR,ECXQDT,ECXNPRFI
-        S QFLG=0,ECED=ECED+.9,ECD=ECSD1,ECXQV=""
-        D QINST I $D(ERR) Q
-        S ECL=+^ACK(509850.8,1,0),ECLINK=^ACK(509850.8,1,"DSS")
-        F  S ECD=$O(^ACK(509850.6,"B",ECD)),ECDA=0 Q:(ECD>ECED)!('ECD)!(QFLG)  D
-        .I +ECXQV=3,ECD<ECXQDT S ECXQV=2.0
-        .F  S ECDA=$O(^ACK(509850.6,"B",ECD,ECDA)) Q:'ECDA  D UPDATE Q:QFLG
-        Q
-QINST   ;Get installed information for QUASAR
-        N ARR,IENS,QVIEN,INTIEN
-        S ECXQDT=""
-        D FILE^DID(509850.6,,"VERSION","ARR","ERR")
-        S ECXQV=$G(ARR("VERSION")) I +ECXQV=0 S ERR=1 Q
-        S QVIEN=$$FIND1^DIC(9.4,"","X","QUASAR") I +QVIEN<1 S ERR=1 Q
-        S IENS=","_QVIEN_","
-        S INTIEN=$$FIND1^DIC(9.49,IENS,"X",ECXQV) I +INTIEN<1 S ERR=1 Q
-        S IENS=INTIEN_","_QVIEN,ECXQDT=$$GET1^DIQ(9.49,IENS,2,"I")
-        Q
-UPDATE  ;create record for each unique CPT code for clinic visit 
-        N ARY,ECZNODE,CPT,LOC,MOD,STR,VOL,XX,ECTP,ECV
-        Q:'$D(^ACK(509850.6,ECDA,0))
-        S ECZNODE=^ACK(509850.6,ECDA,0),EC2NODE=$G(^ACK(509850.6,ECDA,2))
-        S ECDT=$P(ECZNODE,U),ECDAY=$$ECXDATE^ECXUTL(ECDT,ECXYM)
-        S ECTIME=$$ECXTIME^ECXUTL(ECDT) S:$P(ECDT,".",2)="" ECTIME="000000"
-        S ECXDFN=$P(ECZNODE,U,2)
-        Q:'$$PATDEM^ECXUTL2(ECXDFN,ECD,"1;3;5")
-        S OK=$$PAT^ECXUTL3(ECXDFN,ECDT,"1;5",.ECXPAT)
-        I 'OK S ECXERR=1 K ECXPAT Q
-        ;OEF/OIF data
-        S ECXOEF=ECXPAT("ECXOEF")
-        S ECXOEFDT=ECXPAT("ECXOEFDT")
-        ;
-        S ECHL="",ECXDIV=$P($G(^ACK(509850.6,ECDA,5)),U),ECSTOP=$P(EC2NODE,U)
-        S ECXPDIV=$$GETDIV^ECXDEPT(ECXDIV)  ; Get Production Division
-        Q:ECSTOP=""
-        S (ECHLS,ECHL2S)="000",ECAC=$P($G(ECZNODE),U,6)
-        I ECAC D
-        .S ECHL=+$P($G(^SC(ECAC,0)),U,7),ECHL2=+$P($G(^(0)),U,18) I ECHL D
-        ..S ECHLS=$P($G(^DIC(40.7,+ECHL,0)),U,2),ECHL2S=$P($G(^DIC(40.7,+ECHL2,0)),U,2)
-        ..S ECHLS=$$RJ^XLFSTR(ECHLS,3,0),ECHL2S=$$RJ^XLFSTR(ECHL2S,3,0)
-        S ECDSS=ECHLS_ECHL2S
-        I ECXLOGIC>2003 D
-        .I "^18^23^24^36^41^65^94^"[("^"_ECXTS_"^") S ECDSS=$$TSMAP^ECXUTL4(ECXTS)
-        S ECDU=$S(ECSTOP["A":$P(ECLINK,U),ECSTOP["S":$P(ECLINK,U,2),1:"")
-        Q:'ECDU
-        S ECDSSU=$G(^ECD(ECDU,0)),ECCS=+$P(ECDSSU,U,4),(ECO,ECM)=+$P(ECDSSU,U,3),ECXDSSD=$E($P(ECDSSU,U,5),1,10)
-        Q:'$O(^ACK(509850.6,ECDA,3,0))
-        ;Create local array of procedure codes and # of times each procedure
-        ; was performed.
-        F I=1:1:4 S @("ECXICD9"_I)=""
-        S (ECDIA,ECXPPC,ECXPRV1,ECXPRV2,ECXPRV3,ECUN1NPI)=""
-        ;if QUASAR v2
-        I +ECXQV=2 D
-        .S ECXPRV1=$P(EC2NODE,U,7),ECXPRV2=$P(EC2NODE,U,3),ECXPRV3=$P(EC2NODE,U,5),ECPN=0
-        .S ECPR1NPI=$$NPI^XUSNPI("Individual_ID",ECXPRV1,ECD)
-        .S:+ECPR1NPI'>0 ECPR1NPI="" S ECPR1NPI=$P(ECPR1NPI,U)
-        .S ECPR2NPI=$$NPI^XUSNPI("Individual_ID",ECXPRV2,ECD)
-        .S:+ECPR2NPI'>0 ECPR2NPI="" S ECPR2NPI=$P(ECPR2NPI,U)
-        .S ECPR3NPI=$$NPI^XUSNPI("Individual_ID",ECXPRV3,ECD)
-        .S:+ECPR3NPI'>0 ECPR3NPI="" S ECPR3NPI=$P(ECPR3NPI,U)
-        .F  S ECPN=$O(^ACK(509850.6,ECDA,3,ECPN)) Q:'ECPN  D
-        ..S XX=^ACK(509850.6,ECDA,3,ECPN,0),XX=$P(XX,U),XX=$P($G(^ACK(509850.4,XX,0)),U),ECXCPT=$E($$CPT^ECXUTL3(XX),1,5)
-        ..I ECXCPT]"" D
-        ...I '$D(LOC(ECXCPT)) S LOC(ECXCPT)=0_U_ECXPRV1
-        ...S $P(LOC(ECXCPT),U)=$P(LOC(ECXCPT),U)+1
-        .S ECIEN=$O(^ACK(509850.6,ECDA,1,0)),ECDIA=$P($G(^ICD9(+$G(^ACK(509850.6,ECDA,1,ECIEN,0)),0)),U)
-        .F I=1:1:4 S ECIEN=$O(^ACK(509850.6,ECDA,1,ECIEN)) Q:'+ECIEN  D
-        ..S @("ECXICD9"_I)=$P($G(^ICD9(+$P(^ACK(509850.6,ECDA,1,ECIEN,0),U),0)),U)
-        ;if QUASAR v3
-        I +ECXQV=3 D
-        .N CPT,DIA,I,J,MOD,MOD1,P,STR,VOL,ECTP,ARY,ECP,ECPN
-        .S ECXPRV2=$G(^ACK(509850.6,ECDA,2.7,1,0)),ECXPRV3=$G(^ACK(509850.6,ECDA,2.7,2,0))
-        .S ECPN=0 F  S ECPN=$O(^ACK(509850.6,ECDA,3,ECPN)) Q:'ECPN  D
-        ..S CPT=^ACK(509850.6,ECDA,3,ECPN,0),ECXCPT=$P(CPT,U),ECTP=+$P(CPT,U,5),ECV=1,ECP=""
-        ..Q:ECXCPT=""
-        ..I ECTP D
-        ...S CPT=$G(^ACK(509850.6,ECDA,7,ECTP,0)),ECP=$P(CPT,U)
-        ...S ECP=$S(ECP<90000:$P($G(^EC(725,+ECP,0)),U,2)_"N",1:$P($G(^EC(725,+ECP,0)),U,2)_"L")
-        ...S VOL=+$P(CPT,U,2),ECXPRV1=$P(CPT,U,3)
-        ..I 'ECTP S VOL=+$P(CPT,U,3),ECXPRV1=$P(CPT,U,4)
-        ..S ECXCPT=$E($$CPT^ECXUTL3(ECXCPT),1,5),ECXMOD="",MOD=0
-        ..F  S MOD=$O(^ACK(509850.6,ECDA,3,ECPN,1,MOD)) Q:'MOD  D
-        ...S MOD1=+^ACK(509850.6,ECDA,3,ECPN,1,MOD,0) D:MOD1
-        ....S ECXMOD=ECXMOD_MOD1_";"
-        ..F I=1:1:$L(ECXMOD,";") I $G(ARY(ECXCPT))'[$P(ECXMOD,";",I) D
-        ...S ARY(ECXCPT)=$G(ARY(ECXCPT))_$P(ECXMOD,";",I)_";"
-        ..S:VOL ECV=VOL
-        ..S ECV=ECV+$G(LOC(ECXCPT)),LOC(ECXCPT)=ECV_U_ECXPRV1_U_ECP
-        .S ECIEN=0 F  S ECIEN=$O(^ACK(509850.6,ECDA,1,ECIEN)) Q:'ECIEN  D
-        ..S DIA=^ACK(509850.6,ECDA,1,ECIEN,0),P=$P(DIA,U,2),P=$S(P=1:"P",1:"S")
-        ..S CNT=$G(STR(P))+1,STR(P,CNT)=$P($G(^ICD9(+DIA,0)),U),STR(P)=CNT
-        .S ECDIA=$G(STR("P",1))
-        .F I=1:1:4 Q:'$D(STR("P",I+1))  S @("ECXICD9"_I)=STR("P",I)
-        .S:ECDIA="" ECDIA=$G(STR("S",1)),I=2
-        .F J=I:1:4 Q:'$D(STR("S",J))  S @("ECXICD9"_J)=STR("S",J)
-        Q:('$D(LOC))!('$O(^ACK(509850.6,ECDA,1,0)))
-        ;- Ord Div, Contract St/End Dates, Contract Type placeholders for FY2002
-        S (ECXODIV,ECXCSDT,ECXCEDT,ECXCTYP)=""
-        ;set up Provider Person class
-        S (ECXCPT,ECXPPC1,ECXPPC2,ECXPPC3)=""
-        S:ECXPRV2'="" ECXPPC2=$$PRVCLASS^ECXUTL(ECXPRV2,ECD)
-        S:ECXPRV3'="" ECXPPC3=$$PRVCLASS^ECXUTL(ECXPRV3,ECD)
-        N DA,DIC,DIK,DR,FILEN,DIQ,XVAR,II,DI
-        F II=2,3 S XVAR="ECXPRV"_II I @XVAR'="" D
-        .S DA=@XVAR,(DIC,FILEN)=509850.3,DR=".01",DIQ="ECXQSR",DIQ(0)="I" D EN^DIQ1
-        .S DA=ECXQSR(FILEN,DA,DR,"I"),(DIC,FILEN)=8930.3 D EN^DIQ1 S @XVAR=2_ECXQSR(FILEN,DA,DR,"I") K DA,DIC,DR,DIQ,ECXQSR
-        ; -Observation Patient Indicator (yes/no)
-        S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECDSS)
-        ; -CNH status (YES/NO)
-        S ECXCNH=$$CNHSTAT^ECXUTL4(ECXDFN)
-        ;get encounter classification
-        S (ECXAO,ECXECE,ECXIR,ECXMIL,ECXHNC)="",ECXVISIT=$P($G(^ACK(509850.6,ECDA,6)),U,3)
-        I ECXVISIT'="" D
-        .D VISIT^ECXSCX1(ECXDFN,ECXVISIT,.ECXVIST,.ECXERR) I ECXERR K ECXERR Q
-        .S ECXAO=$G(ECXVIST("AO")),ECXECE=$G(ECXVIST("PGE"))
-        .S ECXIR=$G(ECXVIST("IR")),ECXMIL=$G(ECXVIST("MST")),ECXHNC=$G(ECXVIST("HNC"))
-        ; -Head and Neck Cancer Indicator
-        S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN)
-        ;get enrollment data (category, status and priority)
-        I $$ENROLLM^ECXUTL2(ECXDFN)
-        ; -Get national patient record flag Indicator if exist
-        D NPRF^ECXUTL5
-        ; -If no encounter number don't file record
-        S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECDT,ECXTS,ECXOBS,ECHEAD,ECDSS,)
-        Q:ECXENC=""
-        ;Loop through array of unique procedures. Create record in ECODE.
-        S CPT="" F  S CPT=$O(LOC(CPT)) Q:CPT=""  D
-        .S ECV=+$P(LOC(CPT),U),ECXCPT=$$CPT^ECXUTL3(CPT,$G(ARY(CPT)),ECV)
-        .S ECXPRV1=$P(LOC(CPT),U,2)
-        .S:ECXPRV1'="" ECXPPC1=$$PRVCLASS^ECXUTL(ECXPRV1,ECD),ECXPRV1=2_ECXPRV1
-        .S ECP=$P(LOC(CPT),U,3) I ECP="" S ECP=$$CPT^ECXUTL3(CPT,"",ECV)
-        .D FILE^ECXQSR1
-        K CPT,LOC
-        Q
-SETUP   ;Set required input for ECXTRAC
-        S ECHEAD="ECQ"
-        D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
-        Q
-QUE     ;Entry point for the background requeuing handled by ECXTAUTO.
-        D SETUP,QUE^ECXTAUTO,^ECXKILL Q
+ECXQSR ;ALB/JAP,BIR/PTD-DSS QUASAR Extract ; 04/16/07 8:58am
+ ;;3.0;DSS EXTRACTS;**11,8,13,26,24,34,33,35,39,43,46,49,64,71,84,92,106**;Dec 22, 1997;Build 1
+BEG ;entry point from option
+ I '$O(^ACK(509850.8,0)) W !,"You must be using the Quality Audiology & Speech Pathology",!,"Audit & Review (QUASAR) software to run this extract.",!! Q
+ I '$D(^ACK(509850.8,1,"DSS")) W !,"Linkage has not been established between QUASAR and the DSS UNIT file (#724).",!! Q
+ I '$O(^ACK(509850.6,0)) W !,"There is no data in the A&SP CLINIC VISIT file (#509850.6).",!! Q
+ D SETUP I ECFILE="" Q
+ D ^ECXTRAC,^ECXKILL
+ Q
+START ;entry point from tasked job
+ N ERR,ECXQDT,ECXNPRFI
+ S QFLG=0,ECED=ECED+.9,ECD=ECSD1,ECXQV=""
+ D QINST I $D(ERR) Q
+ S ECL=+^ACK(509850.8,1,0),ECLINK=^ACK(509850.8,1,"DSS")
+ F  S ECD=$O(^ACK(509850.6,"B",ECD)),ECDA=0 Q:(ECD>ECED)!('ECD)!(QFLG)  D
+ .I +ECXQV=3,ECD<ECXQDT S ECXQV=2.0
+ .F  S ECDA=$O(^ACK(509850.6,"B",ECD,ECDA)) Q:'ECDA  D UPDATE Q:QFLG
+ Q
+QINST ;Get installed information for QUASAR
+ N ARR,IENS,QVIEN,INTIEN
+ S ECXQDT=""
+ D FILE^DID(509850.6,,"VERSION","ARR","ERR")
+ S ECXQV=$G(ARR("VERSION")) I +ECXQV=0 S ERR=1 Q
+ S QVIEN=$$FIND1^DIC(9.4,"","X","QUASAR") I +QVIEN<1 S ERR=1 Q
+ S IENS=","_QVIEN_","
+ S INTIEN=$$FIND1^DIC(9.49,IENS,"X",ECXQV) I +INTIEN<1 S ERR=1 Q
+ S IENS=INTIEN_","_QVIEN,ECXQDT=$$GET1^DIQ(9.49,IENS,2,"I")
+ Q
+UPDATE ;create record for each unique CPT code for clinic visit 
+ N ARY,ECZNODE,CPT,LOC,MOD,STR,VOL,XX,ECTP,ECV
+ Q:'$D(^ACK(509850.6,ECDA,0))
+ S ECZNODE=^ACK(509850.6,ECDA,0),EC2NODE=$G(^ACK(509850.6,ECDA,2))
+ S ECDT=$P(ECZNODE,U),ECDAY=$$ECXDATE^ECXUTL(ECDT,ECXYM)
+ S ECTIME=$$ECXTIME^ECXUTL(ECDT) S:$P(ECDT,".",2)="" ECTIME="000000"
+ S ECXDFN=$P(ECZNODE,U,2)
+ Q:'$$PATDEM^ECXUTL2(ECXDFN,ECD,"1;3;5")
+ S ECHL="",ECXDIV=$P($G(^ACK(509850.6,ECDA,5)),U),ECSTOP=$P(EC2NODE,U)
+ S ECXPDIV=$$GETDIV^ECXDEPT(ECXDIV)  ; Get Production Division
+ Q:ECSTOP=""
+ S (ECHLS,ECHL2S)="000",ECAC=$P($G(ECZNODE),U,6)
+ I ECAC D
+ .S ECHL=+$P($G(^SC(ECAC,0)),U,7),ECHL2=+$P($G(^(0)),U,18) I ECHL D
+ ..S ECHLS=$P($G(^DIC(40.7,+ECHL,0)),U,2),ECHL2S=$P($G(^DIC(40.7,+ECHL2,0)),U,2)
+ ..S ECHLS=$$RJ^XLFSTR(ECHLS,3,0),ECHL2S=$$RJ^XLFSTR(ECHL2S,3,0)
+ S ECDSS=ECHLS_ECHL2S
+ I ECXLOGIC>2003 D
+ .I "^18^23^24^36^41^65^94^"[("^"_ECXTS_"^") S ECDSS=$$TSMAP^ECXUTL4(ECXTS)
+ S ECDU=$S(ECSTOP["A":$P(ECLINK,U),ECSTOP["S":$P(ECLINK,U,2),1:"")
+ Q:'ECDU
+ S ECDSSU=$G(^ECD(ECDU,0)),ECCS=+$P(ECDSSU,U,4),(ECO,ECM)=+$P(ECDSSU,U,3),ECXDSSD=$E($P(ECDSSU,U,5),1,10)
+ Q:'$O(^ACK(509850.6,ECDA,3,0))
+ ;Create local array of procedure codes and # of times each procedure
+ ; was performed.
+ F I=1:1:4 S @("ECXICD9"_I)=""
+ S (ECDIA,ECXPPC,ECXPRV1,ECXPRV2,ECXPRV3,ECUN1NPI)=""
+ ;if QUASAR v2
+ I +ECXQV=2 D
+ .S ECXPRV1=$P(EC2NODE,U,7),ECXPRV2=$P(EC2NODE,U,3),ECXPRV3=$P(EC2NODE,U,5),ECPN=0
+ .F  S ECPN=$O(^ACK(509850.6,ECDA,3,ECPN)) Q:'ECPN  D
+ ..S XX=^ACK(509850.6,ECDA,3,ECPN,0),XX=$P(XX,U),XX=$P($G(^ACK(509850.4,XX,0)),U),ECXCPT=$E($$CPT^ECXUTL3(XX),1,5)
+ ..I ECXCPT]"" D
+ ...I '$D(LOC(ECXCPT)) S LOC(ECXCPT)=0_U_ECXPRV1
+ ...S $P(LOC(ECXCPT),U)=$P(LOC(ECXCPT),U)+1
+ .S ECIEN=$O(^ACK(509850.6,ECDA,1,0)),ECDIA=$P($G(^ICD9(+$G(^ACK(509850.6,ECDA,1,ECIEN,0)),0)),U)
+ .F I=1:1:4 S ECIEN=$O(^ACK(509850.6,ECDA,1,ECIEN)) Q:'+ECIEN  D
+ ..S @("ECXICD9"_I)=$P($G(^ICD9(+$P(^ACK(509850.6,ECDA,1,ECIEN,0),U),0)),U)
+ ;if QUASAR v3
+ I +ECXQV=3 D
+ .N CPT,DIA,I,J,MOD,MOD1,P,STR,VOL,ECTP,ARY,ECP,ECPN
+ .S ECXPRV2=$G(^ACK(509850.6,ECDA,2.7,1,0)),ECXPRV3=$G(^ACK(509850.6,ECDA,2.7,2,0))
+ .S ECPN=0 F  S ECPN=$O(^ACK(509850.6,ECDA,3,ECPN)) Q:'ECPN  D
+ ..S CPT=^ACK(509850.6,ECDA,3,ECPN,0),ECXCPT=$P(CPT,U),ECTP=+$P(CPT,U,5),ECV=1,ECP=""
+ ..Q:ECXCPT=""
+ ..I ECTP D
+ ...S CPT=$G(^ACK(509850.6,ECDA,7,ECTP,0)),ECP=$P(CPT,U)
+ ...S ECP=$S(ECP<90000:$P($G(^EC(725,+ECP,0)),U,2)_"N",1:$P($G(^EC(725,+ECP,0)),U,2)_"L")
+ ...S VOL=+$P(CPT,U,2),ECXPRV1=$P(CPT,U,3)
+ ..I 'ECTP S VOL=+$P(CPT,U,3),ECXPRV1=$P(CPT,U,4)
+ ..S ECXCPT=$E($$CPT^ECXUTL3(ECXCPT),1,5),ECXMOD="",MOD=0
+ ..F  S MOD=$O(^ACK(509850.6,ECDA,3,ECPN,1,MOD)) Q:'MOD  D
+ ...S MOD1=+^ACK(509850.6,ECDA,3,ECPN,1,MOD,0) D:MOD1
+ ....S ECXMOD=ECXMOD_MOD1_";"
+ ..F I=1:1:$L(ECXMOD,";") I $G(ARY(ECXCPT))'[$P(ECXMOD,";",I) D
+ ...S ARY(ECXCPT)=$G(ARY(ECXCPT))_$P(ECXMOD,";",I)_";"
+ ..S:VOL ECV=VOL
+ ..S ECV=ECV+$G(LOC(ECXCPT)),LOC(ECXCPT)=ECV_U_ECXPRV1_U_ECP
+ .S ECIEN=0 F  S ECIEN=$O(^ACK(509850.6,ECDA,1,ECIEN)) Q:'ECIEN  D
+ ..S DIA=^ACK(509850.6,ECDA,1,ECIEN,0),P=$P(DIA,U,2),P=$S(P=1:"P",1:"S")
+ ..S CNT=$G(STR(P))+1,STR(P,CNT)=$P($G(^ICD9(+DIA,0)),U),STR(P)=CNT
+ .S ECDIA=$G(STR("P",1))
+ .F I=1:1:4 Q:'$D(STR("P",I+1))  S @("ECXICD9"_I)=STR("P",I)
+ .S:ECDIA="" ECDIA=$G(STR("S",1)),I=2
+ .F J=I:1:4 Q:'$D(STR("S",J))  S @("ECXICD9"_J)=STR("S",J)
+ Q:('$D(LOC))!('$O(^ACK(509850.6,ECDA,1,0)))
+ ;- Ord Div, Contract St/End Dates, Contract Type placeholders for FY2002
+ S (ECXODIV,ECXCSDT,ECXCEDT,ECXCTYP)=""
+ ;set up Provider Person class
+ S (ECXCPT,ECXPPC1,ECXPPC2,ECXPPC3)=""
+ S:ECXPRV2'="" ECXPPC2=$$PRVCLASS^ECXUTL(ECXPRV2,ECD)
+ S:ECXPRV3'="" ECXPPC3=$$PRVCLASS^ECXUTL(ECXPRV3,ECD)
+ N DA,DIC,DIK,DR,FILEN,DIQ,XVAR,II,DI
+ F II=2,3 S XVAR="ECXPRV"_II I @XVAR'="" D
+ .S DA=@XVAR,(DIC,FILEN)=509850.3,DR=".01",DIQ="ECXQSR",DIQ(0)="I" D EN^DIQ1
+ .S DA=ECXQSR(FILEN,DA,DR,"I"),(DIC,FILEN)=8930.3 D EN^DIQ1 S @XVAR=2_ECXQSR(FILEN,DA,DR,"I") K DA,DIC,DR,DIQ,ECXQSR
+ ; -Observation Patient Indicator (yes/no)
+ S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECDSS)
+ ; -CNH status (YES/NO)
+ S ECXCNH=$$CNHSTAT^ECXUTL4(ECXDFN)
+ ;get encounter classification
+ S (ECXAO,ECXECE,ECXIR,ECXMIL,ECXHNC)="",ECXVISIT=$P($G(^ACK(509850.6,ECDA,6)),U,3)
+ I ECXVISIT'="" D
+ .D VISIT^ECXSCX1(ECXDFN,ECXVISIT,.ECXVIST,.ECXERR) I ECXERR K ECXERR Q
+ .S ECXAO=$G(ECXVIST("AO")),ECXECE=$G(ECXVIST("PGE"))
+ .S ECXIR=$G(ECXVIST("IR")),ECXMIL=$G(ECXVIST("MST")),ECXHNC=$G(ECXVIST("HNC"))
+ ; -Head and Neck Cancer Indicator
+ S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN)
+ ;get enrollment data (category, status and priority)
+ I $$ENROLLM^ECXUTL2(ECXDFN)
+ ; -Get national patient record flag Indicator if exist
+ D NPRF^ECXUTL5
+ ; -If no encounter number don't file record
+ S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECDT,ECXTS,ECXOBS,ECHEAD,ECDSS,)
+ Q:ECXENC=""
+ ;Loop through array of unique procedures. Create record in ECODE.
+ S CPT="" F  S CPT=$O(LOC(CPT)) Q:CPT=""  D
+ .S ECV=+$P(LOC(CPT),U),ECXCPT=$$CPT^ECXUTL3(CPT,$G(ARY(CPT)),ECV)
+ .S ECXPRV1=$P(LOC(CPT),U,2)
+ .S:ECXPRV1'="" ECXPPC1=$$PRVCLASS^ECXUTL(ECXPRV1,ECD),ECXPRV1=2_ECXPRV1
+ .S ECP=$P(LOC(CPT),U,3) I ECP="" S ECP=$$CPT^ECXUTL3(CPT,"",ECV)
+ .D FILE
+ K CPT,LOC
+ Q
+FILE ;file record in #727.825
+ ;node0
+ ;inst^dfn ECXDFN^ssn ECXSSN^name ECXPNM^i/o status ECXA^day ECDAY^
+ ;DSS unit ECDU^^category ECPTTM^procedure ECP^volume ECV^cost center^
+ ;ordering sec ^section^provider ECXPRV1^ECXPPC1^ECXPRV2^ECXPPC2^ECXPRV3^
+ ;ECXPPC3^mov # ECXMN^treat spec ECXTS^time ECTIME^primary care team 
+ ;ECPTTM^primary care provider ECPTPR^pce cpt code & modifers ECXCPT^
+ ;primary icd-9 code ECDIA^secondary icd-9 #1 ECXICD91^secondary icd-9 
+ ;#2 ECXICD92^secondary icd-9 #3 ECXICD93^secondary icd-9 #4 ECXICD94^
+ ;agent orange ECXAST^radiation exposure ECRST^environmental
+ ;contaminants ECEST^service connected ECSC^sent to pce^^dss identifier
+ ;ECDSS^placeholder
+ ;node1
+ ;mpi ECXNPI^dss dept ECXDSSD^provider npi ECUN1NPI^^^pc prov person 
+ ;class ECPTNPI^assoc pc provider ECASPR^assoc pc prov person class 
+ ;ECCLAS2^assoc pc provider npi ECASNPI^divison ECXDIV^dom ECXDOM^
+ ;enrollment category ECXCAT^enrollment status ECXSTAT^enrollment prior 
+ ;ECXPRIOR^period of service ECXPOS^purple heart ECXPHI^observ pat ind 
+ ;ECXOBS^encounter num ECXENC^ao loc ECXAOL^ord div ECXODIV^contr st dt 
+ ;ECXCSDT^contr end dt ECXCEDT^contr typ ECXCTYP^CNH stat ECXCNH^
+ ;production division ECXPDIV^eligibility ECXELIG^ethnicity ECXETH^
+ ;race1 ECXRC1^enrollment location ECXENRL^^enrollment priority 
+ ;ECXPRIOR_enrollment subgroup ECXSBGRP^user enrollee ECXUESTA^patient 
+ ;type ECXPTYPE^combat vet elig ECXCVE^combat vet elig end date ECXCVEDT^
+ ;enc cv eligible ECXCVENC^national patient record flag ECXNPRFI^
+ ;emergency response indicator(FEMA) ECXERI^agent orange indicator 
+ ;ECXAO^environ contam ECXECE^head/neck ECXHNC^military sexual trauma 
+ ;ECXMIL^radiation encoun ECXIR^nutrition dx
+ N DA,DIK
+ S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1
+ S ECODE=EC7_U_EC23_U
+ S ECODE=ECODE_ECL_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U_ECDAY_U_ECDU_U_U
+ S ECODE=ECODE_ECP_U_ECV_U_ECCS_U_ECO_U_ECM_U_ECXPRV1_U_ECXPPC1_U
+ S ECODE=ECODE_ECXPRV2_U_ECXPPC2_U_ECXPRV3_U_ECXPPC3_U_U
+ S ECODE=ECODE_ECXMN_U_ECXTS_U_ECTIME_U_ECPTTM_U
+ S ECODE=ECODE_ECPTPR_U_ECXCPT_U_ECDIA_U_ECXICD91_U_ECXICD92_U
+ S ECODE=ECODE_ECXICD93_U_ECXICD94_U_ECXAST_U_ECXRST_U_ECXEST_U
+ S ECODE=ECODE_ECSC_U_"N"_U_U_ECDSS_U_U
+ S ECODE1=ECXMPI_U_ECXDSSD_U_ECUN1NPI_U_U_U_ECCLAS_U_ECPTNPI_U_ECASPR_U
+ S ECODE1=ECODE1_ECCLAS2_U_ECASNPI_U_ECXDIV_U_ECXMST_U_ECXDOM_U
+ S ECODE1=ECODE1_ECXDOB_U_ECXCAT_U_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXPOS_U_ECXPHI_U
+ S ECODE1=ECODE1_ECXOBS_U_ECXENC_U_ECXAOL_U_ECXODIV_U_ECXCSDT_U_ECXCEDT_U
+ S ECODE1=ECODE1_ECXCTYP_U_ECXCNH_U_ECXPDIV_U_ECXELIG_U_ECXHNCI_U_ECXETH_U
+ S ECODE1=ECODE1_ECXRC1
+ I ECXLOGIC>2003 S ECODE1=ECODE1_U_ECXENRL
+ I ECXLOGIC>2004 S ECODE1=ECODE1_U_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U
+ I ECXLOGIC>2004 S ECODE2=ECXCVEDT_U_ECXCVENC_U_ECXNPRFI
+ I ECXLOGIC>2006 S ECODE2=ECODE2_U_ECXERI_U_ECXAO_U_ECXECE_U_ECXHNC_U_ECXMIL_U_ECXIR_U
+ S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,^ECX(ECFILE,EC7,2)=$G(ECODE2),ECRN=ECRN+1
+ S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA
+ I $D(ZTQUEUED),$$S^%ZTLOAD
+ Q
+SETUP ;Set required input for ECXTRAC
+ S ECHEAD="ECQ"
+ D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
+ Q
+QUE ;Entry point for the background requeuing handled by ECXTAUTO.
+ D SETUP,QUE^ECXTAUTO,^ECXKILL Q

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXRAD.m

@@ -1 @@
-ECXRAD  ;ALB/JAP,BIR/PDW,PTD-Extract for Radiology ; 5/30/2007
-        ;;3.0;DSS EXTRACTS;**11,8,13,16,24,33,39,46,71,84,92,105**;Dec 22, 1997;Build 70
-BEG     ;entry point from option
-        D SETUP I ECFILE="" Q
-        D ^ECXTRAC,^ECXKILL
-        Q
-        ;
-START   ;start rad extract
-        S QFLG=0
-        K ECXDD D FIELD^DID(70.03,14,,"SPECIFIER","ECXDD") S ECPROF=$E(+$P(ECXDD("SPECIFIER"),"P",2)) K ECXDD
-        S ECXDFN="",ECDT=ECSD-.1,ECED1=ECED+.3
-        F  S ECDT=$O(^RADPT("AR",ECDT)) Q:ECDT>ECED1!(ECDT'>0)  D  Q:QFLG
-        .S ECXDFN=""
-        .F  S ECXDFN=$O(^RADPT("AR",ECDT,ECXDFN)) Q:ECXDFN=""  I '$D(^TMP("ECL",$J,ECXDFN)) D GET Q:QFLG
-        K ^TMP("ECL",$J)
-        Q
-        ;
-GET     ;get data
-        N ECXIEN,X,SUB,TYPE,ECDOCPC,ECXIS,ECXISPC,ECXPRCL,ECXCSC,ECXUSRTN
-        S ^TMP("ECL",$J,ECXDFN)=""
-        ;with dfn get all exams within date range
-        S ECXMDT=ECSD-.1
-        F  S ECXMDT=$O(^RADPT(ECXDFN,"DT","B",ECXMDT)) Q:((ECXMDT>ECED1)!(ECXMDT=""))  D  Q:QFLG
-        .S ECXMDA=$O(^RADPT(ECXDFN,"DT","B",ECXMDT,"")) Q:ECXMDA=""
-        .S ECXIEN=+$P($G(^RADPT(ECXDFN,"DT",ECXMDA,"P",1,0)),U,11)
-        .S ECTM=$$ECXTIME^ECXUTL(ECXMDT) S:ECTM>235959 ECTM=235959
-        .S ECXDAY=$$ECXDATE^ECXUTL(ECXMDT,ECXYM)
-        .K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECXMDT,"."),"1;3",.ECXPAT)
-        .Q:'OK
-        .S ECXPNM=ECXPAT("NAME"),ECXSSN=ECXPAT("SSN"),ECXMPI=ECXPAT("MPI")
-        .;get emergency response indicator (FEMA)
-        .S ECXERI=ECXPAT("ERI")
-        .S X=$$PRIMARY^ECXUTL2(ECXDFN,$P(ECXMDT,"."),ECPROF)
-        .S ECPTTM=$P(X,U,1),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4)
-        .S ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7)
-        .S X=$$INP^ECXUTL2(ECXDFN,ECXMDT),ECXA=$P(X,U),ECXMN=$P(X,U,2)
-        .S ECXTS=$P(X,U,3),ECXDOM=$P(X,U,10),ECXADMDT=$P(X,U,4)
-        .;
-        .;- Observation patient indicator (YES/NO)
-        .S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS)
-        .;for dfn & date get exam(s) ien
-        .S ECXMDA=""
-        .F  S ECXMDA=$O(^RADPT(ECXDFN,"DT","B",ECXMDT,ECXMDA)) Q:+ECXMDA=0  D
-        ..S ECXDIV=$P(^RADPT(ECXDFN,"DT",ECXMDA,0),U,3),ECLOC=$P(^(0),U,4),ECTY=$P(^(0),U,2)
-        ..;
-        ..;- Ordering stop code (based on imaging location)
-        ..S ECXORDST=$$GET1^DIQ(40.7,$$GET1^DIQ(79.1,$G(ECLOC),22,"I"),1)
-        ..;
-        ..;- Get ordering date using Imaging Order ptr to #75.1 in subfile 70.03
-        ..S ECXIEN=+$P($G(^RADPT(ECXDFN,"DT",ECXMDA,"P",1,0)),U,11)
-        ..S ECXORDDT=$$ECXDATE^ECXUTL($P($G(^RAO(75.1,ECXIEN,0)),U,16),ECXYM)
-        ..;
-        ..;- If no encounter number don't file record
-        ..S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXMDT,ECXTS,ECXOBS,ECHEAD,ECTY,) Q:ECXENC=""
-        ..;procedures and modifiers for specific exam (case numbers)
-        ..;ward/clinic,service,provider,diagnostic code
-        ..S ECCN=0
-        ..F  S ECCN=$O(^RADPT(ECXDFN,"DT",ECXMDA,"P",ECCN)) Q:ECCN'>0  D
-        ...S ECCA=^RADPT(ECXDFN,"DT",ECXMDA,"P",ECCN,0)
-        ...S ECXW=$P(ECCA,U,6),ECXW=$P($G(^DIC(42,+ECXW,44)),U)
-        ...S:ECXW="" ECXW=$P(ECCA,U,8)
-        ...S ECDOCNPI=$$NPI^XUSNPI("Individual_ID",$P(ECCA,U,14),ECDT)
-        ...S:+ECDOCNPI'>0 ECDOCNPI="" S ECDOCNPI=$P(ECDOCNPI,U)
-        ...S (ECXDSSD,ECXDSSP)=""
-        ...S ECS=$P(ECCA,U,7),ECDOC=ECPROF_$P(ECCA,U,14),ECDI=$P(ECCA,U,13),ECDOCPC=$$PRVCLASS^ECXUTL($P(ECCA,U,14),ECDT)
-        ...S ECPRO=$P(ECCA,U,2),ECSTAT=$P($G(^RA(72,+$P(ECCA,U,3),0)),U,3)
-        ...;get the primary interpreting staff and the person class DBIA #65
-        ...S ECXIS=$P(ECCA,U,15),ECXISPC=$$PRVCLASS^ECXUTL(ECXIS,ECDT)
-        ...S ECISNPI=$$NPI^XUSNPI("Individual_ID",ECXIS,ECDT)
-        ...S:+ECISNPI'>0 ECISNPI="" S ECISNPI=$P(ECISNPI,U)
-        ...;prefix interpreting radiologist with a "2" if not null
-        ...S ECXIS=$S(ECXIS:"2"_ECXIS,1:"")
-        ...;get the principal clinic ien DBIA #65
-        ...S ECXPRCL=$P(ECCA,U,8)
-        ...;get the clinic stop code from file #44
-        ...S ECXCSC=$$GET1^DIQ(40.7,$$GET1^DIQ(44,ECXPRCL,8,"I"),1)
-        ...Q:'ECPRO 
-        ...Q:+ECSTAT=0
-        ...;get CPT code & modifiers
-        ...S ECPT=+$P($G(^RAMIS(71,+ECPRO,0)),U,9),ECXCMOD=""
-        ...;quit if this is a 'parent' procedure
-        ...S TYPE=$P($G(^RAMIS(71,+ECPRO,0)),U,6)
-        ...Q:((ECPT=0)&(TYPE="P"))
-        ...;if site is using radiology with cpt modifiers then get them
-        ...K ARR,ERR D FIELD^DID(70.03,135,,"LABEL","ARR","ERR")
-        ...I $D(ARR("LABEL")) D
-        ....K ARR,ERR D FIELD^DID(70.03,135,,"GLOBAL SUBSCRIPT LOCATION","ARR","ERR")
-        ....Q:$D(ERR("DIERR"))
-        ....S SUB=$P(ARR("GLOBAL SUBSCRIPT LOCATION"),";") S ECMOD=0
-        ....Q:'$D(^RADPT(ECXDFN,"DT",ECXMDA,"P",ECCN,SUB))
-        ....F  S ECMOD=$O(^RADPT(ECXDFN,"DT",ECXMDA,"P",ECCN,SUB,ECMOD)) Q:ECMOD'>0  S ECXCMOD=ECXCMOD_$P(^(ECMOD,0),U)_";"
-        ...S ECXCPT=$$CPT^ECXUTL3(ECPT,ECXCMOD)
-        ...;get procedure radiology modifiers
-        ...S ECMOD=0,ECMODS=""
-        ...F  S ECMOD=$O(^RADPT(ECXDFN,"DT",ECXMDA,"P",ECCN,"M",ECMOD)) Q:ECMOD'>0  S ECMODS=ECMODS_$P(^(ECMOD,0),U)_";"
-        ...S ECXPDIV=$$RADDIV^ECXDEPT(ECXDIV) ;p-46
-        ...D FILE
-        Q
-        ;
-FILE    ;file record
-        ;node0
-        ;rad div^dfn^ssn^name^in/out (ECXA)^day^cpt code^procedure^img loc^ward^
-        ;ser^diag code^req physician^modifiers^mov #^treat spec^time^
-        ;imaging type^primary care team^primary care provider
-        ;node1
-        ;mpi^dss dept^placeholder^placeholder^pc prov person class^
-        ;assoc pc provider^assoc pc prov person class^placeholder^dom^
-        ;observ pat ind^encounter num^ord stop code^ord date^division^
-        ;dss product ECXDSSP^requesting provider person class ECDOCPC^interp-
-        ;reting radiologist ECXIS^interpreting radiologist pc ECXISPC^princi-
-        ;pal clinic ECXPRCL^clinc stop code ECXCSC^emergency response indicator
-        ;(FEMA) ECXERI^assoc pc provider npi^interpreting rad npi^pc provider npi^req physician npi
-        N DA,DIK
-        S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1
-        S ECODE=EC7_U_EC23_U_ECXDIV_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U
-        S ECODE=ECODE_ECXDAY_U_ECXCPT_U_ECPRO_U_ECLOC_U_ECXW_U_ECS_U_ECDI_U
-        S ECODE=ECODE_ECDOC_U_ECMODS_U_ECXMN_U_ECXTS_U_ECTM_U_ECTY_U_ECPTTM_U
-        S ECODE=ECODE_ECPTPR_U
-        S ECODE1=ECXMPI_U_ECXDSSD_U_U_U_ECCLAS_U_ECASPR_U
-        S ECODE1=ECODE1_ECCLAS2_U_U_ECXDOM_U_ECXOBS_U_ECXENC_U_ECXORDST_U
-        S ECODE1=ECODE1_ECXORDDT_U_ECXPDIV_U
-        I ECXLOGIC>2004 S ECODE1=ECODE1_ECXDSSP_U_ECDOCPC
-        I ECXLOGIC>2005 S ECODE1=ECODE1_U_ECXIS_U_ECXISPC_U_ECXPRCL_U_ECXCSC
-        I ECXLOGIC>2006 S ECODE1=ECODE1_U_ECXERI
-        I ECXLOGIC>2007 S ECODE1=ECODE1_U_ECASNPI_U_ECISNPI_U_ECPTNPI_U_ECDOCNPI
-        S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,ECRN=ECRN+1
-        S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA
-        I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1
-        Q
-        ;
-SETUP   ;Set required input for ECXTRAC
-        S ECHEAD="RAD"
-        D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
-        Q
+ECXRAD ;ALB/JAP,BIR/PDW,PTD-Extract for Radiology ; 6/23/06 6:52am
+ ;;3.0;DSS EXTRACTS;**11,8,13,16,24,33,39,46,71,84,92**;Dec 22, 1997;Build 30
+BEG ;entry point from option
+ D SETUP I ECFILE="" Q
+ D ^ECXTRAC,^ECXKILL
+ Q
+ ;
+START ;start rad extract
+ S QFLG=0
+ K ECXDD D FIELD^DID(70.03,14,,"SPECIFIER","ECXDD") S ECPROF=$E(+$P(ECXDD("SPECIFIER"),"P",2)) K ECXDD
+ S ECXDFN="",ECDT=ECSD-.1,ECED1=ECED+.3
+ F  S ECDT=$O(^RADPT("AR",ECDT)) Q:ECDT>ECED1!(ECDT'>0)  D  Q:QFLG
+ .S ECXDFN=""
+ .F  S ECXDFN=$O(^RADPT("AR",ECDT,ECXDFN)) Q:ECXDFN=""  I '$D(^TMP("ECL",$J,ECXDFN)) D GET Q:QFLG
+ K ^TMP("ECL",$J)
+ Q
+ ;
+GET ;get data
+ N ECXIEN,X,SUB,TYPE,ECDOCPC,ECXIS,ECXISPC,ECXPRCL,ECXCSC
+ S ^TMP("ECL",$J,ECXDFN)=""
+ ;with dfn get all exams within date range
+ S ECXMDT=ECSD-.1
+ F  S ECXMDT=$O(^RADPT(ECXDFN,"DT","B",ECXMDT)) Q:((ECXMDT>ECED1)!(ECXMDT=""))  D  Q:QFLG
+ .S ECXMDA=$O(^RADPT(ECXDFN,"DT","B",ECXMDT,"")) Q:ECXMDA=""
+ .S ECXIEN=+$P($G(^RADPT(ECXDFN,"DT",ECXMDA,"P",1,0)),U,11)
+ .S ECTM=$$ECXTIME^ECXUTL(ECXMDT) S:ECTM>235959 ECTM=235959
+ .S ECXDAY=$$ECXDATE^ECXUTL(ECXMDT,ECXYM)
+ .K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECXMDT,"."),"1;3",.ECXPAT)
+ .Q:'OK
+ .S ECXPNM=ECXPAT("NAME"),ECXSSN=ECXPAT("SSN"),ECXMPI=ECXPAT("MPI")
+ .;get emergency response indicator (FEMA)
+ .S ECXERI=ECXPAT("ERI")
+ .S X=$$PRIMARY^ECXUTL2(ECXDFN,$P(ECXMDT,"."),ECPROF)
+ .S ECPTTM=$P(X,U,1),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4)
+ .S ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7)
+ .S X=$$INP^ECXUTL2(ECXDFN,ECXMDT),ECXA=$P(X,U),ECXMN=$P(X,U,2)
+ .S ECXTS=$P(X,U,3),ECXDOM=$P(X,U,10),ECXADMDT=$P(X,U,4)
+ .;
+ .;- Observation patient indicator (YES/NO)
+ .S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS)
+ .;for dfn & date get exam(s) ien
+ .S ECXMDA=""
+ .F  S ECXMDA=$O(^RADPT(ECXDFN,"DT","B",ECXMDT,ECXMDA)) Q:+ECXMDA=0  D
+ ..S ECXDIV=$P(^RADPT(ECXDFN,"DT",ECXMDA,0),U,3),ECLOC=$P(^(0),U,4),ECTY=$P(^(0),U,2)
+ ..;
+ ..;- Ordering stop code (based on imaging location)
+ ..S ECXORDST=$$GET1^DIQ(40.7,$$GET1^DIQ(79.1,$G(ECLOC),22,"I"),1)
+ ..;
+ ..;- Get ordering date using Imaging Order ptr to #75.1 in subfile 70.03
+ ..S ECXIEN=+$P($G(^RADPT(ECXDFN,"DT",ECXMDA,"P",1,0)),U,11)
+ ..S ECXORDDT=$$ECXDATE^ECXUTL($P($G(^RAO(75.1,ECXIEN,0)),U,16),ECXYM)
+ ..;
+ ..;- If no encounter number don't file record
+ ..S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXMDT,ECXTS,ECXOBS,ECHEAD,ECTY,) Q:ECXENC=""
+ ..;procedures and modifiers for specific exam (case numbers)
+ ..;ward/clinic,service,provider,diagnostic code
+ ..S ECCN=0
+ ..F  S ECCN=$O(^RADPT(ECXDFN,"DT",ECXMDA,"P",ECCN)) Q:ECCN'>0  D
+ ...S ECCA=^RADPT(ECXDFN,"DT",ECXMDA,"P",ECCN,0)
+ ...S ECXW=$P(ECCA,U,6),ECXW=$P($G(^DIC(42,+ECXW,44)),U)
+ ...S:ECXW="" ECXW=$P(ECCA,U,8)
+ ...S (ECXDSSD,ECXDSSP)=""
+ ...S ECS=$P(ECCA,U,7),ECDOC=ECPROF_$P(ECCA,U,14),ECDOCNPI="",ECDI=$P(ECCA,U,13),ECDOCPC=$$PRVCLASS^ECXUTL($P(ECCA,U,14),ECDT)
+ ...S ECPRO=$P(ECCA,U,2),ECSTAT=$P($G(^RA(72,+$P(ECCA,U,3),0)),U,3)
+ ...;get the primary interpreting staff and the person class DBIA #65
+ ...S ECXIS=$P(ECCA,U,15),ECXISPC=$$PRVCLASS^ECXUTL(ECXIS,ECDT)
+ ...;prefix interpreting radiologist with a "2" if not null
+ ...S ECXIS=$S(ECXIS:"2"_ECXIS,1:"")
+ ...;get the principal clinic ien DBIA #65
+ ...S ECXPRCL=$P(ECCA,U,8)
+ ...;get the clinic stop code from file #44
+ ...S ECXCSC=$$GET1^DIQ(40.7,$$GET1^DIQ(44,ECXPRCL,8,"I"),1)
+ ...Q:'ECPRO 
+ ...Q:+ECSTAT=0
+ ...;get CPT code & modifiers
+ ...S ECPT=+$P($G(^RAMIS(71,+ECPRO,0)),U,9),ECXCMOD=""
+ ...;quit if this is a 'parent' procedure
+ ...S TYPE=$P($G(^RAMIS(71,+ECPRO,0)),U,6)
+ ...Q:((ECPT=0)&(TYPE="P"))
+ ...;if site is using radiology with cpt modifiers then get them
+ ...K ARR,ERR D FIELD^DID(70.03,135,,"LABEL","ARR","ERR")
+ ...I $D(ARR("LABEL")) D
+ ....K ARR,ERR D FIELD^DID(70.03,135,,"GLOBAL SUBSCRIPT LOCATION","ARR","ERR")
+ ....Q:$D(ERR("DIERR"))
+ ....S SUB=$P(ARR("GLOBAL SUBSCRIPT LOCATION"),";") S ECMOD=0
+ ....Q:'$D(^RADPT(ECXDFN,"DT",ECXMDA,"P",ECCN,SUB))
+ ....F  S ECMOD=$O(^RADPT(ECXDFN,"DT",ECXMDA,"P",ECCN,SUB,ECMOD)) Q:ECMOD'>0  S ECXCMOD=ECXCMOD_$P(^(ECMOD,0),U)_";"
+ ...S ECXCPT=$$CPT^ECXUTL3(ECPT,ECXCMOD)
+ ...;get procedure radiology modifiers
+ ...S ECMOD=0,ECMODS=""
+ ...F  S ECMOD=$O(^RADPT(ECXDFN,"DT",ECXMDA,"P",ECCN,"M",ECMOD)) Q:ECMOD'>0  S ECMODS=ECMODS_$P(^(ECMOD,0),U)_";"
+ ...S ECXPDIV=$$RADDIV^ECXDEPT(ECXDIV) ;p-46
+ ...D FILE
+ Q
+ ;
+FILE ;file record
+ ;node0
+ ;rad div^dfn^ssn^name^in/out (ECXA)^day^cpt code^procedure^img loc^ward^
+ ;ser^diag code^req physician^modifiers^mov #^treat spec^time^
+ ;imaging type^primary care team^primary care provider
+ ;node1
+ ;mpi^dss dept^req physician npi^pc provider npi^pc prov person class^
+ ;assoc pc provider^assoc pc prov person class^assoc pc prov npi^dom^
+ ;observ pat ind^encounter num^ord stop code^ord date^division^
+ ;dss product ECXDSSP^requesting provider person class ECDOCPC^interp-
+ ;reting radiologist ECXIS^interpreting radiologist pc ECXISPC^princi-
+ ;pal clinic ECXPRCL^clinc stop code ECXCSC^emergency response indicator
+ ;(FEMA) ECXERI
+ N DA,DIK
+ S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1
+ S ECODE=EC7_U_EC23_U_ECXDIV_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U
+ S ECODE=ECODE_ECXDAY_U_ECXCPT_U_ECPRO_U_ECLOC_U_ECXW_U_ECS_U_ECDI_U
+ S ECODE=ECODE_ECDOC_U_ECMODS_U_ECXMN_U_ECXTS_U_ECTM_U_ECTY_U_ECPTTM_U
+ S ECODE=ECODE_ECPTPR_U
+ S ECODE1=ECXMPI_U_ECXDSSD_U_ECDOCNPI_U_ECPTNPI_U_ECCLAS_U_ECASPR_U
+ S ECODE1=ECODE1_ECCLAS2_U_ECASNPI_U_ECXDOM_U_ECXOBS_U_ECXENC_U_ECXORDST_U
+ S ECODE1=ECODE1_ECXORDDT_U_ECXPDIV_U
+ I ECXLOGIC>2004 S ECODE1=ECODE1_ECXDSSP_U_ECDOCPC
+ I ECXLOGIC>2005 S ECODE1=ECODE1_U_ECXIS_U_ECXISPC_U_ECXPRCL_U_ECXCSC
+ I ECXLOGIC>2006 S ECODE1=ECODE1_U_ECXERI
+ S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,ECRN=ECRN+1
+ S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA
+ I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1
+ Q
+ ;
+SETUP ;Set required input for ECXTRAC
+ S ECHEAD="RAD"
+ D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
+ Q

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXSCLD.m

@@ -1 @@
-ECXSCLD ;BIR/DMA,CML-Enter, Print and Edit Entries in 728.44 ; 5/24/07 3:49pm
-        ;;3.0;DSS EXTRACTS;**2,8,24,30,71,80,105**;Dec 22, 1997;Build 70
-EN      ;entry point from option
-        ;load entries
-        W !!,"This option creates local entries in the DSS CLINIC AND STOP CODES file.",!
-        I '$D(^ECX(728.44)) W !,"DSS Clinic stop code file does not exist",!! R X:5 K X Q
-        K ZTSAVE S ZTDESC="Gather Clinic stop codes for DSS",ZTRTN="START^ECXSCLD",ZTIO="" D ^%ZTLOAD
-        Q
-START   ; entry point
-        S EC=0,ECNT=0 F  S EC=$O(^SC(EC)) Q:'EC  I $D(^(EC,0)) S ECD=^(0),DAT=$G(^("I")) I $P(ECD,U,3)="C" D FIX
-        K DIK S DIK="^ECX(728.44,",DIK(1)=".01^B" D ENALL^DIK
-        ;S $P(^ECX(728.44,0),U,3,4)=ECL_U_ECNT
-        K ZTDESC,EC,J,ECD,ECD2,ECL,ECS,ECS2,ECP
-        S ZTREQ="@" Q
-        ;
-FIX     ; get stop codes and default style for feeder key
-        ; 1 if no credit stop code - 5 if credit stop code exists
-        K ECD2,ECS2 I $D(^ECX(728.44,EC,0)) S ECD2=^(0) F ECS=2,3 S ECS2(ECS)=$P(ECD2,U,ECS)
-        S ID=+DAT,RD=$P(DAT,U,2)
-        I $D(ECD2) D
-        .I ID,ID'>DT I 'RD!(RD>DT) S:$P(ECD2,U,10)'=ID $P(ECD2,U,7)="" S $P(ECD2,U,10)=ID
-        .I ID,RD,RD'>DT S:$P(ECD2,U,10) $P(ECD2,U,7)="" S $P(ECD2,U,10)=""
-        .I ID,ID>DT S:$P(ECD2,U,10) $P(ECD2,U,7)="" S $P(ECD2,U,10)=""
-        .I 'ID,$P(ECD2,U,10) S $P(ECD2,U,7)="",$P(ECD2,U,10)=""
-        F ECS=7,18 S ECP=+$P(ECD,U,ECS),ECS(ECS)=$P($G(^DIC(40.7,ECP,0)),U,2)
-        S ECDF=$S(ECS(18)]"":5,1:1) S:$P(ECD,U,17)="Y" ECDF=6 S:$G(^SC(EC,"OOS")) ECDF=6
-        S ECL=EC,ECD=EC_U_ECS(7)_U_ECS(18)
-        I '$D(ECD2) D
-        .S $P(^ECX(728.44,EC,0),U,1,5)=ECD_U_ECS(7)_U_ECS(18),ECNT=ECNT+1,$P(^(0),U,6)=ECDF
-        I $D(ECD2) D
-        .S $P(ECD2,U,1,3)=ECD
-        .I +ECS(7)'=+ECS2(2)!(+ECS(18)'=+ECS2(3)) S $P(ECD2,U,7)=""
-        .S ^ECX(728.44,EC,0)=ECD2
-        Q
-        ;
-PRINT   ; print worksheet for updates
-        I '$O(^ECX(728.44,0)) W !,"DSS Clinic stop code file does not exist",!! R X:5 K X Q
-        W !!,"This option produces a worksheet of (A)ll DSS Clinic Stops or only the",!,"(U)nreviewed Clinic Stops that are awaiting approval.  Clinics that were"
-        W !,"defined as ""inactive"" by MAS the last time the option ""Create DSS Clinic",!,"Stop Code File"" was run will be indicated with an ""*"".",!
-        S DIR(0)="S^A:ALL;U:UNREVIEWED",DIR("A")="Enter ""A"" or ""U""",DIR("?",1)="Enter: ""A"" to print a worksheet of all DSS Clinic Stops,",DIR("?")="       ""U"" to print only the Clinic Stops that have not been approved."
-        D ^DIR K DIR G END:$D(DIRUT) S ECALL=$E(Y)
-        S %ZIS="Q" D ^%ZIS Q:POP
-        I $D(IO("Q")) K ZTSAVE S ZTDESC="DSS clinic stop code work sheet",ZTRTN="SPRINT^ECXSCLD",ZTSAVE("ECALL")="" D ^%ZTLOAD,HOME^%ZIS Q
-        U IO
-SPRINT  ; queued entry to print work sheet
-        S QFLG=0,$P(LN,"-",81)="",PG=0
-        S ECDATE=$O(^ECX(728.44,"A1","")) I ECDATE S ECDATE=-ECDATE,ECDATE=$$FMTE^XLFDT(ECDATE,"5DF"),ECDATE=$TR(ECDATE," ","0")
-        K ^TMP("EC",$J) F J=0:0 S J=$O(^ECX(728.44,J)) Q:'J  I $D(^ECX(728.44,J,0)),$S(ECALL="A":1,1:$P(^(0),U,7)="") S ECSD=^(0) I $D(^SC(J,0)) S ECSC=$P(^(0),U),^TMP("EC",$J,ECSC)=$P(ECSD,U,2,200)
-        D HEAD S ECSC="" I $O(^TMP("EC",$J,ECSC))="" W !!,"NO DATA FOUND FOR WORKSHEET.",! G END
-        F J=1:1 S ECSC=$O(^TMP("EC",$J,ECSC)) Q:ECSC=""  S ECD=^(ECSC) D SHOWEM Q:QFLG
-        I $E(IOST)="C",'QFLG D SS
-        K ^TMP("EC",$J),J,ECSC,ECSD,ECDATE,QFLG,PG,LN,SS
-        W:$Y @IOF D ^%ZISC S ZTREQ="@"
-        Q
-        ;
-HEAD    ; header for worksheet
-        D SS Q:QFLG
-        S PG=PG+1 W:$Y!($E(IOST)="C") @IOF W !,"WORKSHEET FOR DSS CLINIC STOPS",?71,"Page: ",PG
-        I ECDATE]"" W !,"(last reviewed on ",ECDATE,")"
-        E  W !,"(NEVER REVIEWED)"
-        W !
-        W !!,?1,"CLINIC",?31,"STOP",?38,"CREDIT",?47,"DSS",?54,"DSS",?63,"ACTION",?71,"NAT'L"
-        W !,?31,"CODE",?38,"STOP",?47,"STOP",?54,"CREDIT",?71,"CODE",!,?1,"(* - currently inactive)",?38,"CODE",?47,"CODE",?54,"CODE",!,LN Q
-        ;
-SHOWEM  ; list clinics for worksheet
-        I $Y+4>IOSL D HEAD Q:QFLG
-        W !!,$E(ECSC,1,31) W:$P(ECD,U,9)]"" "*" F J=1:1:5 W ?$P("31,38,47,54,66",",",J),$S($P(ECD,U,J):$P(ECD,U,J),J<3:"",1:"_____")
-        S ECN=$P($G(^ECX(728.441,+$P(ECD,U,7),0)),U) W ?71,$S(ECN]"":ECN,1:"____")
-        Q
-SS      ;SCROLL STOPS
-        I $E(IOST)="C" S SS=22-$Y F JJ=1:1:SS W !
-        I $E(IOST)="C",PG>0 S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q
-        Q
-        ;
-EDIT    ; put in DSS stopcodes and which one to send
-        I '$O(^ECX(728.44,0)) W !,"DSS Clinic stop code file does not exist",!! R X:5 K X Q
-        W ! S DIC=728.44,DIC(0)="QEAMZ" D ^DIC G END:Y<0 W !,"STOP CODE : ",$P(Y(0),U,2),!,"CREDIT STOP CODE : ",$P(Y(0),U,3)
-        S DIE=DIC,DA=+Y,DR="3;4;5//1;S:X'=4 Y=6;7;6///"_DT_";8" D ^DIE S:$P(^ECX(728.44,DA,0),U,6)'=4 $P(^(0),U,8)="" S $P(^(0),U,7)="" K DIC,DIE,DA G EDIT
-        ;
-APPROVE ; approve current DSS Stop and Credit Stop codes
-        W !!,"This option allows you to mark the current clinic entries in the CLINICS AND",!,"STOP CODES file (#728.44) as ""reviewed"".  Those entries will then be omitted"
-        W !,"from the list printed from the ""Clinic and DSS Stop Codes Print"" when you",!,"choose to print only ""unreviewed"" clinics.",!
-        K DIR S DIR(0)="Y",DIR("A",1)="Are you ready to approve the reviewed information provided by the",DIR("A")="""Clinic and DSS Stop Codes Print""",DIR("B")="NO"
-        S DIR("?",1)="   Enter:"
-        S DIR("?",2)="     ""YES"" if you concur with the ""Clinic and DSS Stop Codes Print"","
-        S DIR("?",3)="     ""NO"" or <RET> if you do not want to approve the current information,"
-        S DIR("?")="     ""^"" to exit option."
-        D ^DIR K DIR I 'Y!($D(DIRUT)) G END
-        W ! S ZTRTN="APPLOOP^ECXSCLD",ZTIO="",ZTDESC="Approve DSS stop codes for clinic extract" D ^%ZTLOAD W !!,"...approval queued" G END
-        ;
-APPLOOP ; queued entry to approve action codes
-        F EC=0:0 S EC=$O(^ECX(728.44,EC)) Q:'EC  I $D(^(EC,0)) S DA=EC,DIE="^ECX(728.44,",DR="6///"_DT D ^DIE
-        S ZTREQ="@" G END
-END     K X,Y,DA,DR,DIC,DIE,QFLG,PG,LN
-        Q
-        ;
-LOOK    ;queued entry to check for new clinics
-        S ECD=$E(DT,1,5)-1-($E(DT,4,5)="01"*8800),ECD0=ECD_"00",ECXMISS=10,ECGRP="SCX" K ^TMP("ECXS",$J)
-        F EC=0:0 S EC=$O(^SC(EC)) Q:'EC  I $D(^(EC,0)),$P(^(0),U,3)="C",'$D(^ECX(728.44,EC)) S DAT=$G(^SC(EC,"I")) D
-        .S ID=+DAT,RD=$P(DAT,U,2) I ID,ID<DT I 'RD!(RD>DT) Q
-        .S ^TMP("ECXS",$J,ECXMISS,0)=$J(EC,6)_"    "_$$LJ^XLFSTR($P(^SC(EC,0),U),40),ECXMISS=ECXMISS+1
-        D ^ECXSCX1
-        Q
+ECXSCLD ;BIR/DMA,CML-Enter, Print and Edit Entries in 728.44 ; 9/21/04 7:33am
+ ;;3.0;DSS EXTRACTS;**2,8,24,30,71,80**;Dec 22, 1997
+EN ;entry point from option
+ ;load entries
+ W !!,"This option creates local entries in the DSS CLINIC AND STOP CODES file.",!
+ I '$D(^ECX(728.44)) W !,"DSS Clinic stop code file does not exist",!! R X:5 K X Q
+ K ZTSAVE S ZTDESC="Gather Clinic stop codes for DSS",ZTRTN="START^ECXSCLD",ZTIO="" D ^%ZTLOAD
+ Q
+START ; entry point
+ S EC=0,ECNT=0 F  S EC=$O(^SC(EC)) Q:'EC  I $D(^(EC,0)) S ECD=^(0),DAT=$G(^("I")) I $P(ECD,U,3)="C" D FIX
+ K DIK S DIK="^ECX(728.44,",DIK(1)=".01^B" D ENALL^DIK
+ ;S $P(^ECX(728.44,0),U,3,4)=ECL_U_ECNT
+ K ZTDESC,EC,J,ECD,ECD2,ECL,ECS,ECS2,ECP
+ S ZTREQ="@" Q
+ ;
+FIX ; get stop codes and default style for feeder key
+ ; 1 if no credit stop code - 5 if credit stop code exists
+ K ECD2,ECS2 I $D(^ECX(728.44,EC,0)) S ECD2=^(0) F ECS=2,3 S ECS2(ECS)=$P(ECD2,U,ECS)
+ S ID=+DAT,RD=$P(DAT,U,2)
+ I $D(ECD2) D
+ .I ID,ID'>DT I 'RD!(RD>DT) S:$P(ECD2,U,10)'=ID $P(ECD2,U,7)="" S $P(ECD2,U,10)=ID
+ .I ID,RD,RD'>DT S:$P(ECD2,U,10) $P(ECD2,U,7)="" S $P(ECD2,U,10)=""
+ .I ID,ID>DT S:$P(ECD2,U,10) $P(ECD2,U,7)="" S $P(ECD2,U,10)=""
+ .I 'ID,$P(ECD2,U,10) S $P(ECD2,U,7)="",$P(ECD2,U,10)=""
+ F ECS=7,18 S ECP=+$P(ECD,U,ECS),ECS(ECS)=$P($G(^DIC(40.7,ECP,0)),U,2)
+ S ECDF=$S(ECS(18)]"":5,1:1) S:$P(ECD,U,17)="Y" ECDF=6 S:$G(^SC(EC,"OOS")) ECDF=6
+ S ECL=EC,ECD=EC_U_ECS(7)_U_ECS(18)
+ I '$D(ECD2) D
+ .S $P(^ECX(728.44,EC,0),U,1,5)=ECD_U_ECS(7)_U_ECS(18),ECNT=ECNT+1,$P(^(0),U,6)=ECDF
+ I $D(ECD2) D
+ .S $P(ECD2,U,1,3)=ECD
+ .I +ECS(7)'=+ECS2(2)!(+ECS(18)'=+ECS2(3)) S $P(ECD2,U,7)=""
+ .S ^ECX(728.44,EC,0)=ECD2
+ Q
+ ;
+PRINT ; print worksheet for updates
+ I '$O(^ECX(728.44,0)) W !,"DSS Clinic stop code file does not exist",!! R X:5 K X Q
+ W !!,"This option produces a worksheet of (A)ll DSS Clinic Stops or only the",!,"(U)nreviewed Clinic Stops that are awaiting approval.  Clinics that were"
+ W !,"defined as ""inactive"" by MAS the last time the option ""Create DSS Clinic",!,"Stop Code File"" was run will be indicated with an ""*"".",!
+ S DIR(0)="S^A:ALL;U:UNREVIEWED",DIR("A")="Enter ""A"" or ""U""",DIR("?",1)="Enter: ""A"" to print a worksheet of all DSS Clinic Stops,",DIR("?")="       ""U"" to print only the Clinic Stops that have not been approved."
+ D ^DIR K DIR G END:$D(DIRUT) S ECALL=$E(Y)
+ S %ZIS="Q" D ^%ZIS Q:POP
+ I $D(IO("Q")) K ZTSAVE S ZTDESC="DSS clinic stop code work sheet",ZTRTN="SPRINT^ECXSCLD",ZTSAVE("ECALL")="" D ^%ZTLOAD,HOME^%ZIS Q
+ U IO
+SPRINT ; queued entry to print work sheet
+ S QFLG=0,$P(LN,"-",81)="",PG=0
+ S ECDATE=$O(^ECX(728.44,"A1","")) I ECDATE S ECDATE=-ECDATE,ECDATE=$$FMTE^XLFDT(ECDATE,"5DF"),ECDATE=$TR(ECDATE," ","0")
+ K ^TMP("EC",$J) F J=0:0 S J=$O(^ECX(728.44,J)) Q:'J  I $D(^ECX(728.44,J,0)),$S(ECALL="A":1,1:$P(^(0),U,7)="") S ECSD=^(0) I $D(^SC(J,0)) S ECSC=$P(^(0),U),^TMP("EC",$J,ECSC)=$P(ECSD,U,2,200)
+ D HEAD S ECSC="" I $O(^TMP("EC",$J,ECSC))="" W !!,"NO DATA FOUND FOR WORKSHEET.",! G END
+ F J=1:1 S ECSC=$O(^TMP("EC",$J,ECSC)) Q:ECSC=""  S ECD=^(ECSC) D SHOWEM Q:QFLG
+ I $E(IOST)="C",'QFLG D SS
+ K ^TMP("EC",$J),J,ECSC,ECSD,ECDATE,QFLG,PG,LN,SS
+ W:$Y @IOF D ^%ZISC S ZTREQ="@"
+ Q
+ ;
+HEAD ; header for worksheet
+ D SS Q:QFLG
+ S PG=PG+1 W:$Y!($E(IOST)="C") @IOF W !,"WORKSHEET FOR DSS CLINIC STOPS",?71,"Page: ",PG
+ I ECDATE]"" W !,"(last reviewed on ",ECDATE,")"
+ E  W !,"(NEVER REVIEWED)"
+ W !
+ W !!,?1,"CLINIC",?27,"STOP",?34,"CREDIT",?43,"DSS",?50,"DSS",?59,"ACTION",?67,"NAT'L",?74,"DSS"
+ W !,?27,"CODE",?34,"STOP",?43,"STOP",?50,"CREDIT",?67,"CODE",?74,"DEPT",!,?1,"(* - currently inactive)",?34,"CODE",?43,"CODE",?50,"CODE",!,LN Q
+ ;
+SHOWEM ; list clinics for worksheet
+ I $Y+4>IOSL D HEAD Q:QFLG
+ W !!,$E(ECSC,1,25) W:$P(ECD,U,9)]"" "*" F J=1:1:5 W ?$P("27,34,43,50,62",",",J),$S($P(ECD,U,J):$P(ECD,U,J),J<3:"",1:"_____")
+ S ECN=$P($G(^ECX(728.441,+$P(ECD,U,7),0)),U) W ?67,$S(ECN]"":ECN,1:"____"),?74,$S($P(ECD,U,10)'="":$P(ECD,U,10),1:"___")
+ Q
+SS ;SCROLL STOPS
+ I $E(IOST)="C" S SS=22-$Y F JJ=1:1:SS W !
+ I $E(IOST)="C",PG>0 S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q
+ Q
+ ;
+EDIT ; put in DSS stopcodes and which one to send
+ I '$O(^ECX(728.44,0)) W !,"DSS Clinic stop code file does not exist",!! R X:5 K X Q
+ W ! S DIC=728.44,DIC(0)="QEAMZ" D ^DIC G END:Y<0 W !,"STOP CODE : ",$P(Y(0),U,2),!,"CREDIT STOP CODE : ",$P(Y(0),U,3)
+ S DIE=DIC,DA=+Y,DR="3;4;5//1;S:X'=4 Y=6;7;6///"_DT_";8" D ^DIE S:$P(^ECX(728.44,DA,0),U,6)'=4 $P(^(0),U,8)="" S $P(^(0),U,7)="" K DIC,DIE,DA G EDIT
+ ;
+APPROVE ; approve current DSS Stop and Credit Stop codes
+ W !!,"This option allows you to mark the current clinic entries in the CLINICS AND",!,"STOP CODES file (#728.44) as ""reviewed"".  Those entries will then be omitted"
+ W !,"from the list printed from the ""Clinic and DSS Stop Codes Print"" when you",!,"choose to print only ""unreviewed"" clinics.",!
+ K DIR S DIR(0)="Y",DIR("A",1)="Are you ready to approve the reviewed information provided by the",DIR("A")="""Clinic and DSS Stop Codes Print""",DIR("B")="NO"
+ S DIR("?",1)="   Enter:"
+ S DIR("?",2)="     ""YES"" if you concur with the ""Clinic and DSS Stop Codes Print"","
+ S DIR("?",3)="     ""NO"" or <RET> if you do not want to approve the current information,"
+ S DIR("?")="     ""^"" to exit option."
+ D ^DIR K DIR I 'Y!($D(DIRUT)) G END
+ W ! S ZTRTN="APPLOOP^ECXSCLD",ZTIO="",ZTDESC="Approve DSS stop codes for clinic extract" D ^%ZTLOAD W !!,"...approval queued" G END
+ ;
+APPLOOP ; queued entry to approve action codes
+ F EC=0:0 S EC=$O(^ECX(728.44,EC)) Q:'EC  I $D(^(EC,0)) S DA=EC,DIE="^ECX(728.44,",DR="6///"_DT D ^DIE
+ S ZTREQ="@" G END
+END K X,Y,DA,DR,DIC,DIE,QFLG,PG,LN
+ Q
+ ;
+LOOK ;queued entry to check for new clinics
+ S ECD=$E(DT,1,5)-1-($E(DT,4,5)="01"*8800),ECD0=ECD_"00",ECXMISS=10,ECGRP="SCX" K ^TMP("ECXS",$J)
+ F EC=0:0 S EC=$O(^SC(EC)) Q:'EC  I $D(^(EC,0)),$P(^(0),U,3)="C",'$D(^ECX(728.44,EC)) S DAT=$G(^SC(EC,"I")) D
+ .S ID=+DAT,RD=$P(DAT,U,2) I ID,ID<DT I 'RD!(RD>DT) Q
+ .S ^TMP("ECXS",$J,ECXMISS,0)=$J(EC,6)_"    "_$$LJ^XLFSTR($P(^SC(EC,0),U),40),ECXMISS=ECXMISS+1
+ D ^ECXSCX1
+ Q

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXSCX1.m

@@ -1 @@
-ECXSCX1 ;ALB/JAP,BIR/DMA-Clinic Extract Message ; 4/11/07 3:26pm
-        ;;3.0;DSS EXTRACTS;**8,28,24,27,29,30,31,33,84,92,105**;Dec 22, 1997;Build 70
-EN      ;entry point from ecxscx
-        N ECX
-        ;send missing clinic message
-        S ECX=$O(^TMP($J,"ECXS","MISS",0)) D
-        .Q:ECX=""
-        .S XMSUB="MISSING CLINICS in File #728.44",XMDUZ="DSS SYSTEM"
-        .K XMY S XMY("G.DSS-"_ECGRP_"@"_^XMB("NETNAME"))=""
-        .F ECX=1:1:5 S ^TMP($J,"ECXS","MISS",ECX,0)=$P($T(MSG+ECX),";;",2)
-        .S XMTEXT="^TMP($J,""ECXS"",""MISS""," D ^XMD
-        ;send no division message
-        S ECX=$O(^TMP($J,"ECXS","DIV",0)) D
-        .Q:ECX=""
-        .S XMSUB="CLINICS w/o DIVISION Data",XMDUZ="DSS SYSTEM"
-        .K XMY S XMY("G.DSS-"_ECGRP_"@"_^XMB("NETNAME"))=""
-        .F ECX=1:1:5 S ^TMP($J,"ECXS","DIV",ECX,0)=$P($T(MSG2+ECX),";;",2)
-        .S XMTEXT="^TMP($J,""ECXS"",""DIV""," D ^XMD
-        ;cleanup
-        K ^TMP($J,"ECXS")
-        Q
-MSG     ;text for missing clinic
-        ;;The following clinics have not been entered into the CLINIC AND
-        ;;STOP CODES file (#728.44).  If any listed clinic is currently
-        ;;active, please use the options 'Create DSS Clinic Stop Code File'
-        ;;and 'Enter/Edit DSS Stop Codes for Clinics' to update this file.
-        ;;  
-        ;
-MSG2    ;text for missing division
-        ;;The following clinics in the HOSPITAL LOCATION file (#44) have not
-        ;;been assigned to a division from the MEDICAL CENTER DIVISION file 
-        ;;(#40.8).  CLI extract records associated with these clinics have
-        ;;been given a default Division identifier of "1".
-        ;;
-        ;
-MISS    ;load ^tmp if clinic missing from #728.44
-        N DAT,ID,RD
-        S (ID,RD)=""
-        S DAT=$G(^SC(SC,"I")) I DAT]"" S ID=+DAT,RD=$P(DAT,U,2)
-        ;ignore inactive clinics
-        I ID,ID<DT I 'RD!(RD>DT) Q
-        I '$D(^TMP($J,"ECXS","ECXMISS")) S ^TMP($J,"ECXS","ECXMISS")=10
-        S ECXMISS=^TMP($J,"ECXS","ECXMISS")
-        S ^TMP($J,"ECXS","MISS",ECXMISS,0)=$J(SC,6)_"    "_$$LJ^XLFSTR($P(^SC(SC,0),U),40)_ECSC_"/"_ECCSC
-        S ^TMP($J,"ECXS","ECXMISS")=ECXMISS+1
-        Q
-        ;
-NODIV   ;load ^tmp if clinic w/o division
-        N DAT,ID,RD
-        S (ID,RD)=""
-        S DAT=$G(^SC(SC,"I")) I DAT]"" S ID=+DAT,RD=$P(DAT,U,2)
-        ;ignore inactive clinics
-        I ID,ID<DT I 'RD!(RD>DT) Q
-        I '$D(^TMP($J,"ECXS","ECXMISS")) S ^TMP($J,"ECXS","ECXMISS")=10
-        S ECXMISS=^TMP($J,"ECXS","ECXMISS")
-        S ^TMP($J,"ECXS","DIV",ECXMISS,0)=$J(SC,6)_"    "_$$LJ^XLFSTR($P(^SC(SC,0),U),40)
-        S ^TMP($J,"ECXS","ECXMISS")=ECXMISS+1
-        Q
-        ;
-FEEDER(ECXSC,ECXSD,ECXP1,ECXP2,ECXP3,ECXSEND,ECXDIV)    ;get transmission style and feeder key variables
-        ;feeder key = primary stop code_secondary stop code_length of appointment_national clinic code_noshow indicator
-        ;   input
-        ;   ECXSC = ien of clinic in file #44 (required)
-        ;   ECXSD  = start date of extract date range (required)
-        ;   ECXP1,ECXP2,ECXP3,ECXSEND passed by reference (required)
-        ;   output (passed-by-reference variables)
-        ;   ECXP1  = primary stop code
-        ;   ECXP2  = secondary stop code
-        ;   ECXP3  = field #7 of file #728.44
-        ;   ECXSEND = field #5 of file #728.44
-        ;   ECXDIV  = field #3.5 of file #44
-        N ECSC,ECCSC,ECSD1,ECXNC,ECXMISS,CLIN,SC
-        S (ECXP1,ECXP2)="000",ECXP3="0000"
-        S ECXSEND=1,ECXDIV=0
-        Q:+ECXSC=0
-        ;get needed data from ^tmp
-        I $D(^TMP($J,"ECXS","SC",ECXSC)) D
-        .S CLIN=^TMP($J,"ECXS","SC",ECXSC)
-        .S ECXP1=$P(CLIN,U),ECXP2=$P(CLIN,U,2),ECXP3=$P(CLIN,U,3),ECXSEND=$P(CLIN,U,4),ECXDIV=$P(CLIN,U,5)
-        .S ECXDIV=+$P($G(^TMP($J,"ECXCL",ECXSC)),U,4) S:ECXDIV=0 ECXDIV=1
-        ;otherwise, set needed data in ^tmp
-        I '$D(^TMP($J,"ECXS","SC",ECXSC)) D
-        .;get division or send no division msg
-        .S ECXDIV=+$P($G(^TMP($J,"ECXCL",ECXSC)),U,4)
-        .I ECXDIV=0 S SC=ECXSC D NODIV S ECXDIV=1
-        .;get other data from file #44 if no #727.44 record; send missing clinic msg
-        .I '$D(^ECX(728.44,ECXSC,0)) D
-        ..S ECSC=+$P($G(^SC(ECXSC,0)),U,7),ECCSC=+$P(^(0),U,18)
-        ..S SC=ECXSC,ECSD1=ECXSD D MISS
-        ..S:ECSC ECXP1=$P($G(^DIC(40.7,ECSC,0)),U,2),ECXP1=$$RJ^XLFSTR(+ECXP1,3,0)
-        .;otherwise get other data from file #728.44
-        .S EC=$G(^ECX(728.44,ECXSC,0)) D
-        ..Q:EC=""
-        ..S ECXSEND=$P(EC,U,6)
-        ..Q:ECXSEND=6
-        ..S ECSC=+$P(EC,U,4),ECCSC=+$P(EC,U,5)
-        ..I 'ECSC S ECSC=+$P(EC,U,2),ECCSC=+$P(EC,U,3)
-        ..I ECSC S ECXP1=$$RJ^XLFSTR(ECSC,3,0),ECXP2=$$RJ^XLFSTR(ECCSC,3,0)
-        ..;if primary stop not valid, use file #44 record
-        ..I 'ECSC S ECSC=+$P($G(^SC(ECXSC,0)),U,7),ECCSC=+$P($G(^(0)),U,18) I ECSC D
-        ...S ECXP1=+$P($G(^DIC(40.7,ECSC,0)),U,2)
-        ...S:ECCSC ECXP2=+$P($G(^DIC(40.7,ECCSC,0)),U,2)
-        ...S ECXP1=$$RJ^XLFSTR(ECXP1,3,0),ECXP2=$$RJ^XLFSTR(ECXP2,3,0)
-        .;for action code=1, secondary stop code is always "000"
-        .I ECXSEND=1 S ECXP2="000"
-        .;action code of 2 or 3 should not be used, but continue to follow v2t11 logic
-        .I ECXSEND=2 S ECXP1=ECXP2,ECXP2="000"
-        .;for action code=4, need to get national clinic code
-        .I ECXSEND=4 D
-        ..S ECXNC=+$P($G(^ECX(728.44,ECXSC,0)),U,8)
-        ..I ECXNC S ECXNC=$P($G(^ECX(728.441,ECXNC,0)),U),ECXP3=$$RJ^XLFSTR(ECXNC,4,0)
-        .;set data in ^tmp
-        .S ^TMP($J,"ECXS","SC",ECXSC)=ECXP1_U_ECXP2_U_ECXP3_U_ECXSEND
-        Q
-        ;
-VISIT(ECXDFN,ECXVISIT,ECXVIST,ECXERR)   ;get visit specific data
-        ;input  ECXVISIT  = pointer to file #9000010
-        ;       ECXSVC  = sc percentage
-        ;output ECXVSIT = data array
-        ;       ECXERR  = 1 indicates error; otherwise, 0
-        N AO,ARRAY,CM,CNT,CPT,DA,DATE,DA,DIQ,ICD,ICD9,IR,LEN,M,MOD,MST,NUM
-        N PROV,PROVPC,REC,VAL,VISIT,X,Y,PGE
-        S ECXERR=0,VISIT=ECXVISIT
-        S (ECXVIST("AO"),ECXVIST("IR"),ECXVIST("PGE"),ECXVIST("HNC"))=""
-        S (ECXVIST("MST"),ECXVIST("PROV"),ECXVIST("PROV CLASS"))=""
-        S (ECXVIST("PROV NPI"),ECXVIST("SOURCE"))=""
-        F I="P",1,2,3,4 S ECXVIST("ICD9"_I)=""
-        F I=1:1:8 S ECXVIST("CPT"_I)=""
-        D ENCEVENT^PXAPI(VISIT)
-        I $O(^TMP("PXKENC",$J,VISIT,""))']"" K ECXVIST S ECXERR=1
-        Q:ECXERR
-        S DATE=$P($P(^TMP("PXKENC",$J,VISIT,"VST",VISIT,0),U,1),".",1)
-        S ECXVIST("SOURCE")=$P($G(^TMP("PXKENC",$J,VISIT,"VST",VISIT,812)),U,3)
-        ;get icd9 codes upto 5; else use 799.9
-        K ARY S ICD("P")=0,ICD("S")=0,(ARY,REC)=""
-        F  S REC=$O(^TMP("PXKENC",$J,VISIT,"POV",REC)) Q:REC=""  D
-        .S VAL=^TMP("PXKENC",$J,VISIT,"POV",REC,0) Q:'VAL
-        .I $P(VAL,U,12)="P" D
-        ..S:'$D(ARY("P",+VAL)) CNT=ICD("P")+1,ICD("P",CNT)=+VAL,ICD("P")=CNT
-        ..S ARY("P",+VAL)=""
-        .I $P(VAL,U,12)'="P" D
-        ..S:'$D(ARY("S",+VAL)) CNT=ICD("S")+1,ICD("S",CNT)=+VAL,ICD("S")=CNT
-        ..S ARY("S",+VAL)=""
-        S CNT=0,ECXVIST("ICD9P")=$P($G(^ICD9(+$G(ICD("P",1),0),0)),U)
-        F I=2:1 Q:'$D(ICD("P",I))  D  Q:CNT>4
-        .S CNT=CNT+1,ECXVIST("ICD9"_CNT)=$P($G(^ICD9(ICD("P",I),0)),U)
-        I CNT<4 F I=1:1:8 Q:'$D(ICD("S",I))  D  Q:CNT>4
-        .I '$D(ARY("P",ICD("S",I))) D
-        ..S CNT=CNT+1,ECXVIST("ICD9"_CNT)=$P($G(^ICD9(ICD("S",I),0)),U)
-        ;get first provider designated as primary
-        ;if no primary, then get first physician provider
-        ;if no physician, then get first provider
-        S (PROV,PROVPC)=""
-        I $O(^TMP("PXKENC",$J,VISIT,"PRV",0)) D
-        .S (REC,VAL)=0 D
-        ..F  S REC=$O(^TMP("PXKENC",$J,VISIT,"PRV",REC)) Q:('REC)!(VAL)  D
-        ...S:($P(^(REC,0),U,4)="P") VAL=+^(0)
-        ...S PROV=VAL,PROVPC=$$PRVCLASS^ECXUTL(PROV,DATE)
-        .I 'VAL S (REC,VAL)=0 D
-        ..F  S REC=$O(^TMP("PXKENC",$J,VISIT,"PRV",REC)) Q:('REC)!(VAL)  D
-        ...S (PROV,VAL)=+^(REC,0)
-        ...S PROVPC=$$PRVCLASS^ECXUTL(PROV,DATE) Q:PROVPC=""
-        ...S NUM=$E(PROVPC,2,7) S:(NUM<110000)!(NUM>119999) VAL=0,PROVPC=""
-        .I 'VAL D
-        ..S REC=$O(^TMP("PXKENC",$J,VISIT,"PRV",0)) Q:('REC)!(VAL)
-        ..S VAL=+^(REC,0),PROV=VAL,PROVPC=$$PRVCLASS^ECXUTL(PROV,DATE)
-        .S:PROV]"" PROV="2"_PROV
-        S ECXVIST("PROV")=PROV,ECXVIST("PROV CLASS")=PROVPC
-        S ECXVIST("PROV NPI")=""
-        ;get cpt codes upto 8 & modifiers upto 5
-        S CNT=1,PROV=$E(PROV,2,99)
-        D:$O(^TMP("PXKENC",$J,VISIT,"CPT",0))
-        .S REC=0 D:PROV]""
-        ..F  S REC=$O(^TMP("PXKENC",$J,VISIT,"CPT",REC)) Q:'REC  D  Q:CNT>8
-        ...S CPT="",NODE=$G(^TMP("PXKENC",$J,VISIT,"CPT",REC,12))
-        ...Q:NODE=""
-        ...S NOD1=$S($P(NODE,U,4)=PROV:^TMP("PXKENC",$J,VISIT,"CPT",REC,0),1:"")
-        ...Q:$P(NOD1,U)=""
-        ...S Q="00"_+$P(NOD1,U,16),Q=$S(+Q:$E(Q,$L(Q)-1,$L(Q)),1:"01")
-        ...S CPT=$P(NOD1,U),M=0,MOD=""
-        ...F I=1:1:5 S M=$O(^TMP("PXKENC",$J,VISIT,"CPT",REC,1,M)) Q:'M  D
-        ....S MOD=MOD_$S(MOD'="":";",1:"")
-        ....S MOD=MOD_$P(^TMP("PXKENC",$J,VISIT,"CPT",REC,1,M,0),U)
-        ...S ECXVIST("CPT"_CNT)=$$CPT^ECXUTL3(CPT,MOD,Q),CNT=CNT+1
-        ...K ^TMP("PXKENC",$J,VISIT,"CPT",REC)
-        ..Q:CNT>8
-        .Q:CNT>8  S REC=0
-        .F  S REC=$O(^TMP("PXKENC",$J,VISIT,"CPT",REC)) Q:'REC  D  Q:CNT>8
-        ..S CPT="",NOD1=$G(^TMP("PXKENC",$J,VISIT,"CPT",REC,0))
-        ..Q:$P(NOD1,U)=""
-        ..S Q="00"_+$P(NOD1,U,16),Q=$S(+Q:$E(Q,$L(Q)-1,$L(Q)),1:"01")
-        ..S CPT=$P(NOD1,U),M=0,MOD=""
-        ..F I=1:1:5 S M=$O(^TMP("PXKENC",$J,VISIT,"CPT",REC,1,M)) Q:'M  D
-        ...S MOD=MOD_$S(MOD'="":";",1:"")
-        ...S MOD=MOD_$P(^TMP("PXKENC",$J,VISIT,"CPT",REC,1,M,0),U)
-        ..S ECXVIST("CPT"_CNT)=$$CPT^ECXUTL3(CPT,MOD,Q),CNT=CNT+1
-        ..K ^TMP("PXKENC",$J,VISIT,"CPT",REC)
-        ..Q:CNT>8
-        S:ECXVIST("CPT1")="" ECXVIST("CPT1")=9919901
-        ;ao, ir, mst, pge, hnc
-        S (AO,IR,MST,PGE,HNC)=""
-        I $D(^TMP("PXKENC",$J,VISIT,"VST",VISIT,800)) D
-        .S AO=$P(^TMP("PXKENC",$J,VISIT,"VST",VISIT,800),U,2)
-        .S IR=$P(^TMP("PXKENC",$J,VISIT,"VST",VISIT,800),U,3),MST=$P(^(800),U,5)
-        .S PGE=$P(^TMP("PXKENC",$J,VISIT,"VST",VISIT,800),U,4),HNC=$P(^(800),U,6)
-        .S ECXVIST("AO")=$S(AO=0:"N",AO=1:"Y",1:"")
-        .S ECXVIST("IR")=$S(IR=0:"N",IR=1:"Y",1:"")
-        .S ECXVIST("MST")=$S(MST=0:"N",MST=1:"Y",1:"")
-        .S ECXVIST("PGE")=$S(PGE=0:"N",PGE=1:"Y",1:"")
-        .S ECXVIST("HNC")=$S(HNC=0:"N",HNC=1:"Y",1:"")
-        Q
+ECXSCX1 ;ALB/JAP,BIR/DMA-Clinic Extract Message ; 8/17/06 7:59am
+ ;;3.0;DSS EXTRACTS;**8,28,24,27,29,30,31,33,84,92**;Dec 22, 1997;Build 30
+EN ;entry point from ecxscx
+ N ECX
+ ;send missing clinic message
+ S ECX=$O(^TMP($J,"ECXS","MISS",0)) D
+ .Q:ECX=""
+ .S XMSUB="MISSING CLINICS in File #728.44",XMDUZ="DSS SYSTEM"
+ .K XMY S XMY("G.DSS-"_ECGRP_"@"_^XMB("NETNAME"))=""
+ .F ECX=1:1:5 S ^TMP($J,"ECXS","MISS",ECX,0)=$P($T(MSG+ECX),";;",2)
+ .S XMTEXT="^TMP($J,""ECXS"",""MISS""," D ^XMD
+ ;send no division message
+ S ECX=$O(^TMP($J,"ECXS","DIV",0)) D
+ .Q:ECX=""
+ .S XMSUB="CLINICS w/o DIVISION Data",XMDUZ="DSS SYSTEM"
+ .K XMY S XMY("G.DSS-"_ECGRP_"@"_^XMB("NETNAME"))=""
+ .F ECX=1:1:5 S ^TMP($J,"ECXS","DIV",ECX,0)=$P($T(MSG2+ECX),";;",2)
+ .S XMTEXT="^TMP($J,""ECXS"",""DIV""," D ^XMD
+ ;cleanup
+ K ^TMP($J,"ECXS")
+ Q
+MSG ;text for missing clinic
+ ;;The following clinics have not been entered into the CLINIC AND
+ ;;STOP CODES file (#728.44).  If any listed clinic is currently
+ ;;active, please use the options 'Create DSS Clinic Stop Code File'
+ ;;and 'Enter/Edit DSS Stop Codes for Clinics' to update this file.
+ ;;  
+ ;
+MSG2 ;text for missing division
+ ;;The following clinics in the HOSPITAL LOCATION file (#44) have not
+ ;;been assigned to a division from the MEDICAL CENTER DIVISION file 
+ ;;(#40.8).  CLI extract records associated with these clinics have
+ ;;been given a default Division identifier of "1".
+ ;;
+ ;
+MISS ;load ^tmp if clinic missing from #728.44
+ N DAT,ID,RD
+ S (ID,RD)=""
+ S DAT=$G(^SC(SC,"I")) I DAT]"" S ID=+DAT,RD=$P(DAT,U,2)
+ ;ignore inactive clinics
+ I ID,ID<DT I 'RD!(RD>DT) Q
+ I '$D(^TMP($J,"ECXS","ECXMISS")) S ^TMP($J,"ECXS","ECXMISS")=10
+ S ECXMISS=^TMP($J,"ECXS","ECXMISS")
+ S ^TMP($J,"ECXS","MISS",ECXMISS,0)=$J(SC,6)_"    "_$$LJ^XLFSTR($P(^SC(SC,0),U),40)_ECSC_"/"_ECCSC
+ S ^TMP($J,"ECXS","ECXMISS")=ECXMISS+1
+ Q
+ ;
+NODIV ;load ^tmp if clinic w/o division
+ N DAT,ID,RD
+ S (ID,RD)=""
+ S DAT=$G(^SC(SC,"I")) I DAT]"" S ID=+DAT,RD=$P(DAT,U,2)
+ ;ignore inactive clinics
+ I ID,ID<DT I 'RD!(RD>DT) Q
+ I '$D(^TMP($J,"ECXS","ECXMISS")) S ^TMP($J,"ECXS","ECXMISS")=10
+ S ECXMISS=^TMP($J,"ECXS","ECXMISS")
+ S ^TMP($J,"ECXS","DIV",ECXMISS,0)=$J(SC,6)_"    "_$$LJ^XLFSTR($P(^SC(SC,0),U),40)
+ S ^TMP($J,"ECXS","ECXMISS")=ECXMISS+1
+ Q
+ ;
+FEEDER(ECXSC,ECXSD,ECXP1,ECXP2,ECXP3,ECXSEND,ECXDIV) ;get transmission style and feeder key variables
+ ;feeder key = primary stop code_secondary stop code_length of appointment_national clinic code_noshow indicator
+ ;   input
+ ;   ECXSC = ien of clinic in file #44 (required)
+ ;   ECXSD  = start date of extract date range (required)
+ ;   ECXP1,ECXP2,ECXP3,ECXSEND passed by reference (required)
+ ;   output (passed-by-reference variables)
+ ;   ECXP1  = primary stop code
+ ;   ECXP2  = secondary stop code
+ ;   ECXP3  = field #7 of file #728.44
+ ;   ECXSEND = field #5 of file #728.44
+ ;   ECXDIV  = field #3.5 of file #44
+ N ECSC,ECCSC,ECSD1,ECXNC,ECXMISS,CLIN,SC
+ S (ECXP1,ECXP2)="000",ECXP3="0000"
+ S ECXSEND=1,ECXDIV=0
+ Q:+ECXSC=0
+ ;get needed data from ^tmp
+ I $D(^TMP($J,"ECXS","SC",ECXSC)) D
+ .S CLIN=^TMP($J,"ECXS","SC",ECXSC)
+ .S ECXP1=$P(CLIN,U),ECXP2=$P(CLIN,U,2),ECXP3=$P(CLIN,U,3),ECXSEND=$P(CLIN,U,4),ECXDIV=$P(CLIN,U,5)
+ .S ECXDIV=+$P($G(^TMP($J,"ECXCL",ECXSC)),U,4) S:ECXDIV=0 ECXDIV=1
+ ;otherwise, set needed data in ^tmp
+ I '$D(^TMP($J,"ECXS","SC",ECXSC)) D
+ .;get division or send no division msg
+ .S ECXDIV=+$P($G(^TMP($J,"ECXCL",ECXSC)),U,4)
+ .I ECXDIV=0 S SC=ECXSC D NODIV S ECXDIV=1
+ .;get other data from file #44 if no #727.44 record; send missing clinic msg
+ .I '$D(^ECX(728.44,ECXSC,0)) D
+ ..S ECSC=+$P($G(^SC(ECXSC,0)),U,7),ECCSC=+$P(^(0),U,18)
+ ..S SC=ECXSC,ECSD1=ECXSD D MISS
+ ..S:ECSC ECXP1=$P($G(^DIC(40.7,ECSC,0)),U,2),ECXP1=$$RJ^XLFSTR(+ECXP1,3,0)
+ .;otherwise get other data from file #728.44
+ .S EC=$G(^ECX(728.44,ECXSC,0)) D
+ ..Q:EC=""
+ ..S ECXSEND=$P(EC,U,6)
+ ..Q:ECXSEND=6
+ ..S ECSC=+$P(EC,U,4),ECCSC=+$P(EC,U,5)
+ ..I 'ECSC S ECSC=+$P(EC,U,2),ECCSC=+$P(EC,U,3)
+ ..I ECSC S ECXP1=$$RJ^XLFSTR(ECSC,3,0),ECXP2=$$RJ^XLFSTR(ECCSC,3,0)
+ ..;if primary stop not valid, use file #44 record
+ ..I 'ECSC S ECSC=+$P($G(^SC(ECXSC,0)),U,7),ECCSC=+$P($G(^(0)),U,18) I ECSC D
+ ...S ECXP1=+$P($G(^DIC(40.7,ECSC,0)),U,2)
+ ...S:ECCSC ECXP2=+$P($G(^DIC(40.7,ECCSC,0)),U,2)
+ ...S ECXP1=$$RJ^XLFSTR(ECXP1,3,0),ECXP2=$$RJ^XLFSTR(ECXP2,3,0)
+ .;for action code=1, secondary stop code is always "000"
+ .I ECXSEND=1 S ECXP2="000"
+ .;action code of 2 or 3 should not be used, but continue to follow v2t11 logic
+ .I ECXSEND=2 S ECXP1=ECXP2,ECXP2="000"
+ .;for action code=4, need to get national clinic code
+ .I ECXSEND=4 D
+ ..S ECXNC=+$P($G(^ECX(728.44,ECXSC,0)),U,8)
+ ..I ECXNC S ECXNC=$P($G(^ECX(728.441,ECXNC,0)),U),ECXP3=$$RJ^XLFSTR(ECXNC,4,0)
+ .;set data in ^tmp
+ .S ^TMP($J,"ECXS","SC",ECXSC)=ECXP1_U_ECXP2_U_ECXP3_U_ECXSEND
+ Q
+ ;
+VISIT(ECXDFN,ECXVISIT,ECXVIST,ECXERR) ;get visit specific data
+ ;input  ECXVISIT  = pointer to file #9000010
+ ;       ECXSVC  = sc percentage
+ ;output ECXVSIT = data array
+ ;       ECXERR  = 1 indicates error; otherwise, 0
+ N AO,ARRAY,CM,CNT,CPT,DA,DATE,DA,DIQ,ICD,ICD9,IR,LEN,M,MOD,MST,NUM
+ N PROV,PROVPC,REC,VAL,VISIT,X,Y,PGE
+ S ECXERR=0,VISIT=ECXVISIT
+ S (ECXVIST("AO"),ECXVIST("IR"),ECXVIST("PGE"),ECXVIST("HNC"))=""
+ S (ECXVIST("MST"),ECXVIST("PROV"),ECXVIST("PROV CLASS"))=""
+ S (ECXVIST("PROV NPI"),ECXVIST("SOURCE"))=""
+ F I="P",1,2,3,4 S ECXVIST("ICD9"_I)=""
+ F I=1:1:8 S ECXVIST("CPT"_I)=""
+ D ENCEVENT^PXAPI(VISIT)
+ I $O(^TMP("PXKENC",$J,VISIT,""))']"" K ECXVIST S ECXERR=1
+ Q:ECXERR
+ S DATE=$P($P(^TMP("PXKENC",$J,VISIT,"VST",VISIT,0),U,1),".",1)
+ S ECXVIST("SOURCE")=$P($G(^TMP("PXKENC",$J,VISIT,"VST",VISIT,812)),U,3)
+ ;get icd9 codes upto 5; else use 799.9
+ K ARY S ICD("P")=0,ICD("S")=0,(ARY,REC)=""
+ F  S REC=$O(^TMP("PXKENC",$J,VISIT,"POV",REC)) Q:REC=""  D
+ .S VAL=^TMP("PXKENC",$J,VISIT,"POV",REC,0) Q:'VAL
+ .I $P(VAL,U,12)="P" D
+ ..S:'$D(ARY("P",+VAL)) CNT=ICD("P")+1,ICD("P",CNT)=+VAL,ICD("P")=CNT
+ ..S ARY("P",+VAL)=""
+ .I $P(VAL,U,12)'="P" D
+ ..S:'$D(ARY("S",+VAL)) CNT=ICD("S")+1,ICD("S",CNT)=+VAL,ICD("S")=CNT
+ ..S ARY("S",+VAL)=""
+ S CNT=0,ECXVIST("ICD9P")=$P($G(^ICD9(+$G(ICD("P",1),0),0)),U)
+ F I=2:1 Q:'$D(ICD("P",I))  D  Q:CNT>4
+ .S CNT=CNT+1,ECXVIST("ICD9"_CNT)=$P($G(^ICD9(ICD("P",I),0)),U)
+ I CNT<4 F I=1:1:8 Q:'$D(ICD("S",I))  D  Q:CNT>4
+ .I '$D(ARY("P",ICD("S",I))) D
+ ..S CNT=CNT+1,ECXVIST("ICD9"_CNT)=$P($G(^ICD9(ICD("S",I),0)),U)
+ S:(ECXVIST("ICD9P")="")&(ECXVIST("ICD91")="") ECXVIST("ICD9P")="799.9"
+ ;get first provider designated as primary
+ ;if no primary, then get first physician provider
+ ;if no physician, then get first provider
+ S (PROV,PROVPC)=""
+ I $O(^TMP("PXKENC",$J,VISIT,"PRV",0)) D
+ .S (REC,VAL)=0 D
+ ..F  S REC=$O(^TMP("PXKENC",$J,VISIT,"PRV",REC)) Q:('REC)!(VAL)  D
+ ...S:($P(^(REC,0),U,4)="P") VAL=+^(0)
+ ...S PROV=VAL,PROVPC=$$PRVCLASS^ECXUTL(PROV,DATE)
+ .I 'VAL S (REC,VAL)=0 D
+ ..F  S REC=$O(^TMP("PXKENC",$J,VISIT,"PRV",REC)) Q:('REC)!(VAL)  D
+ ...S (PROV,VAL)=+^(REC,0)
+ ...S PROVPC=$$PRVCLASS^ECXUTL(PROV,DATE) Q:PROVPC=""
+ ...S NUM=$E(PROVPC,2,7) S:(NUM<110000)!(NUM>119999) VAL=0,PROVPC=""
+ .I 'VAL D
+ ..S REC=$O(^TMP("PXKENC",$J,VISIT,"PRV",0)) Q:('REC)!(VAL)
+ ..S VAL=+^(REC,0),PROV=VAL,PROVPC=$$PRVCLASS^ECXUTL(PROV,DATE)
+ .S:PROV]"" PROV="2"_PROV
+ S ECXVIST("PROV")=PROV,ECXVIST("PROV CLASS")=PROVPC
+ S ECXVIST("PROV NPI")=""
+ ;get cpt codes upto 8 & modifiers upto 5
+ S CNT=1,PROV=$E(PROV,2,99)
+ D:$O(^TMP("PXKENC",$J,VISIT,"CPT",0))
+ .S REC=0 D:PROV]""
+ ..F  S REC=$O(^TMP("PXKENC",$J,VISIT,"CPT",REC)) Q:'REC  D  Q:CNT>8
+ ...S CPT="",NODE=$G(^TMP("PXKENC",$J,VISIT,"CPT",REC,12))
+ ...Q:NODE=""
+ ...S NOD1=$S($P(NODE,U,4)=PROV:^TMP("PXKENC",$J,VISIT,"CPT",REC,0),1:"")
+ ...Q:$P(NOD1,U)=""
+ ...S Q="00"_+$P(NOD1,U,16),Q=$S(+Q:$E(Q,$L(Q)-1,$L(Q)),1:"01")
+ ...S CPT=$P(NOD1,U),M=0,MOD=""
+ ...F I=1:1:5 S M=$O(^TMP("PXKENC",$J,VISIT,"CPT",REC,1,M)) Q:'M  D
+ ....S MOD=MOD_$S(MOD'="":";",1:"")
+ ....S MOD=MOD_$P(^TMP("PXKENC",$J,VISIT,"CPT",REC,1,M,0),U)
+ ...S ECXVIST("CPT"_CNT)=$$CPT^ECXUTL3(CPT,MOD,Q),CNT=CNT+1
+ ...K ^TMP("PXKENC",$J,VISIT,"CPT",REC)
+ ..Q:CNT>8
+ .Q:CNT>8  S REC=0
+ .F  S REC=$O(^TMP("PXKENC",$J,VISIT,"CPT",REC)) Q:'REC  D  Q:CNT>8
+ ..S CPT="",NOD1=$G(^TMP("PXKENC",$J,VISIT,"CPT",REC,0))
+ ..Q:$P(NOD1,U)=""
+ ..S Q="00"_+$P(NOD1,U,16),Q=$S(+Q:$E(Q,$L(Q)-1,$L(Q)),1:"01")
+ ..S CPT=$P(NOD1,U),M=0,MOD=""
+ ..F I=1:1:5 S M=$O(^TMP("PXKENC",$J,VISIT,"CPT",REC,1,M)) Q:'M  D
+ ...S MOD=MOD_$S(MOD'="":";",1:"")
+ ...S MOD=MOD_$P(^TMP("PXKENC",$J,VISIT,"CPT",REC,1,M,0),U)
+ ..S ECXVIST("CPT"_CNT)=$$CPT^ECXUTL3(CPT,MOD,Q),CNT=CNT+1
+ ..K ^TMP("PXKENC",$J,VISIT,"CPT",REC)
+ ..Q:CNT>8
+ S:ECXVIST("CPT1")="" ECXVIST("CPT1")=9919901
+ ;ao, ir, mst, pge, hnc
+ S (AO,IR,MST,PGE,HNC)=""
+ I $D(^TMP("PXKENC",$J,VISIT,"VST",VISIT,800)) D
+ .S AO=$P(^TMP("PXKENC",$J,VISIT,"VST",VISIT,800),U,2)
+ .S IR=$P(^TMP("PXKENC",$J,VISIT,"VST",VISIT,800),U,3),MST=$P(^(800),U,5)
+ .S PGE=$P(^TMP("PXKENC",$J,VISIT,"VST",VISIT,800),U,4),HNC=$P(^(800),U,6)
+ .S ECXVIST("AO")=$S(AO=0:"N",AO=1:"Y",1:"")
+ .S ECXVIST("IR")=$S(IR=0:"N",IR=1:"Y",1:"")
+ .S ECXVIST("MST")=$S(MST=0:"N",MST=1:"Y",1:"")
+ .S ECXVIST("PGE")=$S(PGE=0:"N",PGE=1:"Y",1:"")
+ .S ECXVIST("HNC")=$S(HNC=0:"N",HNC=1:"Y",1:"")
+ Q

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXSCX2.m

@@ -1 @@
-ECXSCX2 ;ALB/ESD  DSS Clinic Extract Utilities (continued) ; 6/5/2007
-        ;;3.0;DSS EXTRACTS;**39,46,49,71,84,92,105**;Dec 22, 1997;Build 70
-        ;
-        ;
-INTPAT  ;initialize patient variables
-        S (ECXSSN,ECXPNM,ECPTPR,ECCLAS,ECPTNPI,ECASPR,ECCLAS2,ECASNPI,ECXZIP)=""
-        S (ECPTTM,ECXVET,ECXRACE,ECXENRL,ECXMPI,ECXSEX)=""
-        S (ECXDOB,ECXELIG,ECXPST,ECXPLOC,ECXRST,ECXAST,ECXMST,ECXSTATE)=""
-        S (ECXCNTY,ECXATYP,ECXPVST,ECXMTST,ECXEST,ECXECE,ECXHNC)=""
-        Q
-        ;
-PAT1(ECXDFN,ECXDATE,ECXERR)         ;get patient demographic data
-        N ECXPAT,K,OK,X
-        S ECXERR=0
-        S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECXDATE,"."),"1;2;3;4;5",.ECXPAT)
-        I 'OK S ECXERR=1 Q
-        S ECXSSN=ECXPAT("SSN"),ECXPNM=ECXPAT("NAME"),ECXMPI=ECXPAT("MPI")
-        S ECXSEX=ECXPAT("SEX"),ECXDOB=ECXPAT("DOB"),ECXELIG=ECXPAT("ELIG")
-        S ECXVET=ECXPAT("VET"),ECXSVC=ECXPAT("SC%"),ECXRACE=ECXPAT("RACE")
-        S ECXPST=ECXPAT("POW STAT"),ECXPLOC=ECXPAT("POW LOC")
-        S ECXRST=ECXPAT("IR STAT"),ECXAST=ECXPAT("AO STAT")
-        S ECXMST=ECXPAT("MST STAT"),ECXSTATE=ECXPAT("STATE")
-        S ECXCNTY=ECXPAT("COUNTY"),ECXZIP=ECXPAT("ZIP")
-        S ECXENRL=ECXPAT("ENROLL LOC"),ECXMTST=ECXPAT("MEANS")
-        ; changes for 2001
-        S ECXPOS=ECXPAT("POS"),ECXPHI=ECXPAT("PHI")
-        ;- Agent Orange location
-        S ECXAOL=ECXPAT("AOL")
-        ;OEF/OIF data
-        S ECXOEF=ECXPAT("ECXOEF")
-        S ECXOEFDT=ECXPAT("ECXOEFDT")
-        I $$ENROLLM^ECXUTL2(ECXDFN)
-        ; - Head and Neck Cancer Indicator
-        S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN)
-        ; - Race and Ethnicity
-        S ECXETH=ECXPAT("ETHNIC")
-        S ECXRC1=ECXPAT("RACE1")
-        ; - Environmental Contaminants
-        S ECXEST=ECXPAT("EC STAT")
-        ;get emergency response indicator (FEMA)
-        S ECXERI=ECXPAT("ERI")
-        Q
-        ;
-PAT2(ECXDFN,ECXDATE)       ;get date specific patient data
-        N K,X
-        ;get primary care data
-        S X=$$PRIMARY^ECXUTL2(ECXDFN,$P(ECXDATE,"."))
-        S ECPTTM=$P(X,U),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4)
-        S ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7)
-        ;get inpatient data
-        S X=$$INP^ECXUTL2(ECXDFN,ECXDATE),ECXA=$P(X,U),ECXTS=$P(X,U,3)
-        S ECXDOM=$P(X,U,10),ECXADMDT=$P(X,U,4)
-        ;- set national patient record flag if exist
-        D NPRF^ECXUTL5
-        Q
-        ;
-FILE2(ECXFILE,EC7,ECODE)        ;file record
-        N DA,DIK,X S X=""
-        F  S X=$O(ECODE(X)) Q:X=""  S ^ECX(ECXFILE,EC7,X)=ECODE(X)
-        S DA=EC7,DIK="^ECX("_ECXFILE_"," D IX1^DIK K DIK,DA
-        I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1
-        Q
-        ;
-CBOC(MDIV)      ;Determine whether patient's facility was CBOC
-        N LOCARR,DIC,DR,DIQ,DA,INST,FTYP
-        S DIC=40.8,DA=MDIV,DR=".07",DIQ(0)="I",DIQ="LOCARR" D EN^DIQ1
-        S INST=$G(LOCARR(40.8,MDIV,.07,"I")) I INST="" Q ""
-        K LOCARR S DIC=4,DA=INST,DR="13",DIQ(0)="I",DIQ="LOCARR" D EN^DIQ1
-        S FTYP=$G(LOCARR(4,INST,13,"I")) I FTYP="" Q ""
-        K LOCARR S DIC=4.1,DA=FTYP,DR=".01",DIQ(0)="I",DIQ="LOCARR" D EN^DIQ1
-        Q $S($G(LOCARR(4.1,FTYP,.01,"I"))="CBOC":"Y",1:"")
+ECXSCX2 ;ALB/ESD  DSS Clinic Extract Utilities (continued) ; 11/2/06 8:59am
+ ;;3.0;DSS EXTRACTS;**39,46,49,71,84,92**;Dec 22, 1997;Build 30
+ ;
+ ;
+INTPAT ;initialize patient variables
+ S (ECXSSN,ECXPNM,ECPTPR,ECCLAS,ECPTNPI,ECASPR,ECCLAS2,ECASNPI,ECXZIP)=""
+ S (ECPTTM,ECXVET,ECXRACE,ECXENRL,ECXMPI,ECXSEX)=""
+ S (ECXDOB,ECXELIG,ECXPST,ECXPLOC,ECXRST,ECXAST,ECXMST,ECXSTATE)=""
+ S (ECXCNTY,ECXATYP,ECXPVST,ECXMTST,ECXEST,ECXECE,ECXHNC)=""
+ Q
+ ;
+PAT1(ECXDFN,ECXDATE,ECXERR)     ;get patient demographic data
+ N ECXPAT,K,OK,X
+ S ECXERR=0
+ S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECXDATE,"."),"1;2;3;4;5",.ECXPAT)
+ I 'OK S ECXERR=1 Q
+ S ECXSSN=ECXPAT("SSN"),ECXPNM=ECXPAT("NAME"),ECXMPI=ECXPAT("MPI")
+ S ECXSEX=ECXPAT("SEX"),ECXDOB=ECXPAT("DOB"),ECXELIG=ECXPAT("ELIG")
+ S ECXVET=ECXPAT("VET"),ECXSVC=ECXPAT("SC%"),ECXRACE=ECXPAT("RACE")
+ S ECXPST=ECXPAT("POW STAT"),ECXPLOC=ECXPAT("POW LOC")
+ S ECXRST=ECXPAT("IR STAT"),ECXAST=ECXPAT("AO STAT")
+ S ECXMST=ECXPAT("MST STAT"),ECXSTATE=ECXPAT("STATE")
+ S ECXCNTY=ECXPAT("COUNTY"),ECXZIP=ECXPAT("ZIP")
+ S ECXENRL=ECXPAT("ENROLL LOC"),ECXMTST=ECXPAT("MEANS")
+ ; changes for 2001
+ S ECXPOS=ECXPAT("POS"),ECXPHI=ECXPAT("PHI")
+ ;- Agent Orange location
+ S ECXAOL=ECXPAT("AOL")
+ I $$ENROLLM^ECXUTL2(ECXDFN)
+ ; - Head and Neck Cancer Indicator
+ S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN)
+ ; - Race and Ethnicity
+ S ECXETH=ECXPAT("ETHNIC")
+ S ECXRC1=ECXPAT("RACE1")
+ ; - Environmental Contaminants
+ S ECXEST=ECXPAT("EC STAT")
+ ;get emergency response indicator (FEMA)
+ S ECXERI=ECXPAT("ERI")
+ Q
+ ;
+PAT2(ECXDFN,ECXDATE)    ;get date specific patient data
+ N K,X
+ ;get primary care data
+ S X=$$PRIMARY^ECXUTL2(ECXDFN,$P(ECXDATE,"."))
+ S ECPTTM=$P(X,U),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4)
+ S ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7)
+ ;get inpatient data
+ S X=$$INP^ECXUTL2(ECXDFN,ECXDATE),ECXA=$P(X,U),ECXTS=$P(X,U,3)
+ S ECXDOM=$P(X,U,10),ECXADMDT=$P(X,U,4)
+ ;- set national patient record flag if exist
+ D NPRF^ECXUTL5
+ Q
+ ;
+FILE2(ECXFILE,EC7,ECODE) ;file record
+ N DA,DIK,X S X=""
+ F  S X=$O(ECODE(X)) Q:X=""  S ^ECX(ECXFILE,EC7,X)=ECODE(X)
+ S DA=EC7,DIK="^ECX("_ECXFILE_"," D IX1^DIK K DIK,DA
+ I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1
+ Q
+ ;
+CBOC(MDIV) ;Determine whether patient's facility was CBOC
+ N LOCARR,DIC,DR,DIQ,DA,INST,FTYP
+ S DIC=40.8,DA=MDIV,DR=".07",DIQ(0)="I",DIQ="LOCARR" D EN^DIQ1
+ S INST=$G(LOCARR(40.8,MDIV,.07,"I")) I INST="" Q ""
+ K LOCARR S DIC=4,DA=INST,DR="13",DIQ(0)="I",DIQ="LOCARR" D EN^DIQ1
+ S FTYP=$G(LOCARR(4,INST,13,"I")) I FTYP="" Q ""
+ K LOCARR S DIC=4.1,DA=FTYP,DR=".01",DIQ(0)="I",DIQ="LOCARR" D EN^DIQ1
+ Q $S($G(LOCARR(4.1,FTYP,.01,"I"))="CBOC":"Y",1:"")

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXSCXN.m

@@ -1 @@
-ECXSCXN ;ALB/JAP  Clinic Extract ; 6/5/07 11:55am
-        ;;3.0;DSS EXTRACTS;**24,27,29,30,31,32,33,39,46,49,52,71,84,92,107,105**;Dec 22, 1997;Build 70
-        ;
-BEG     ;entry point from option
-        D SETUP Q:ECFILE=""  D ^ECXTRAC,^ECXKILL
-        Q
-        ;
-START   ;entry point from taskmgr
-        N DIC,EXNUM,I,LOCARR,OUT,P1,P2,P3,PROCESS,SOURCE,STOP,STAT,TOSEND
-        N TIU,X,Y,ECXNPRFI
-        F I=1:1:8 S @("ECXCPT"_I)=""
-        F I=1:1:4 S @("ECXICD9"_I)=""
-        S (OUT,QFLG,ECRN)=0,(ECXICD9P,ECXOBI)=""
-        K ^TMP($J,"ECXS"),^TMP($J,"ECXCL")
-        ;get ien for tiu in file #839.7
-        S DIC="^PX(839.7,",DIC(0)="X",X="TEXT INTEGRATION UTILITIES"
-        D ^DIC S TIU=+Y,ECED=ECED+.3,ECXCLIN=0 K DIC,Y
-        ;get clinic default appt length, type, division
-        F  S ECXCLIN=$O(^SC(ECXCLIN)) Q:'ECXCLIN  D
-        .K LOCARR S DIC=44,DA=ECXCLIN,DR="2;3.5;1912",DIQ(0)="I",DIQ="LOCARR"
-        .D EN^DIQ1
-        .Q:$G(LOCARR(44,ECXCLIN,2,"I"))'="C"
-        .S ALEN=+$G(LOCARR(44,ECXCLIN,1912,"I"))
-        .S ^TMP($J,"ECXCL",ECXCLIN)=ALEN,ALEN=$$RJ^XLFSTR(ALEN,3,0)
-        .S ^TMP($J,"ECXCL",ECXCLIN)=^TMP($J,"ECXCL",ECXCLIN)_"^"_ALEN_"^"_$G(LOCARR(44,ECXCLIN,2,"I"))_"^"_+$G(LOCARR(44,ECXCLIN,3.5,"I"))
-        .D FEEDER^ECXSCX1(ECXCLIN,ECSD1,.P1,.P2,.P3,.TOSEND,.ECXDIV)
-        .K P1,P2,P3,TOSEND,ECXDIV
-        ;get from file #44 any no-shows & get encounters from #409.68
-        D NOSHOW^ECXSCXN1(ECSD1,ECED),ENCNTR(ECSD1,ECED)
-        ;send missing clinic msg
-        D:$D(^TMP($J,"ECXS")) EN^ECXSCX1
-        K ^TMP($J,"ECXS"),^TMP($J,"ECXCL")
-        Q
-        ;
-ENCNTR(ECSD1,ECED)      ;search file #409.68 for encounter data
-        N CHKOUT,ECD,JJ,K,OUT,PNODE,PP,STAT,STOP,MDIV
-        S ECD=ECSD1
-        F  S ECD=$O(^SCE("B",ECD)) Q:('ECD!(ECD>ECED))!(QFLG)  S ECXIEN=0 D
-        .F  S ECXIEN=$O(^SCE("B",ECD,ECXIEN)) Q:'ECXIEN  D  Q:QFLG
-        ..Q:'$D(^SCE(ECXIEN,0))
-        ..D INTPAT^ECXSCX2 K LOCARR S DIC=409.68,DA=ECXIEN
-        ..S DR=".01;.02;.03;.04;.05;.06;.07;.08;.11;.12;.13",DIQ(0)="I",DIQ="LOCARR"
-        ..D EN^DIQ1
-        ..S ECXTI=$P($$FMTE^XLFDT(+$G(LOCARR(409.68,ECXIEN,.01,"I")),1),"@",2)
-        ..S ECXTI=$E(($TR(ECXTI,":","")_"000000"),1,6)
-        ..S:ECXTI="000000" ECXTI="000300" S MDIV=+$G(LOCARR(409.68,ECXIEN,.11,"I"))
-        ..S STOP=+$G(LOCARR(409.68,ECXIEN,.03,"I"))
-        ..S CHKOUT=+$G(LOCARR(409.68,ECXIEN,.07,"I"))
-        ..S PROCESS=+$G(LOCARR(409.68,ECXIEN,.08,"I"))
-        ..S STAT=$G(LOCARR(409.68,ECXIEN,.12,"I"))
-        ..S ECXDFN=+$G(LOCARR(409.68,ECXIEN,.02,"I"))
-        ..Q:(ECXDFN=0)!('CHKOUT)
-        ..S:STAT="" STAT="ZZ" S STAT=";"_STAT_";"
-        ..Q:";3;4;5;6;7;9;10;13;"[STAT
-        ..Q:('STOP)!(PROCESS=4)!(+$G(LOCARR(409.68,ECXIEN,.06,"I")))
-        ..S ECXDATE=+$G(LOCARR(409.68,ECXIEN,.01,"I"))
-        ..S ECXCLIN=+$G(LOCARR(409.68,ECXIEN,.04,"I"))
-        ..Q:$P($G(^TMP($J,"ECXCL",ECXCLIN)),U,3)'="C"
-        ..S ECXVISIT=+$G(LOCARR(409.68,ECXIEN,.05,"I"))
-        ..S ECXENEL=+$G(LOCARR(409.68,ECXIEN,.13,"I"))
-        ..Q:'ECXVISIT
-        ..S ECXERR=0
-        ..D PAT1^ECXSCX2(ECXDFN,ECXDATE,.ECXERR) Q:ECXERR
-        ..D FEEDER^ECXSCX1(ECXCLIN,ECSD1,.P1,.P2,.P3,.TOSEND,.ECXDIV)
-        ..Q:TOSEND=6
-        ..K LOCARR S DIC=40.7,DA=STOP,DR="1",DIQ(0)="I",DIQ="LOCARR" D EN^DIQ1
-        ..S ECXSTOP=$$RJ^XLFSTR($G(LOCARR(40.7,STOP,1,"I")),3,0)
-        ..;get date specific patient data
-        ..D PAT2^ECXSCX2(ECXDFN,ECXDATE)
-        ..;get national patient record flag if exist
-        ..D NPRF^ECXUTL5
-        ..;get visit specific data
-        ..S ECXERR=0 D VISIT^ECXSCX1(ECXDFN,ECXVISIT,.ECXVIST,.ECXERR) Q:ECXERR
-        ..F I=1:1:8 S @("ECXCPT"_I)=$G(ECXVIST("CPT"_I))
-        ..S ECXICD9P=$G(ECXVIST("ICD9P"))
-        ..F I=1:1:4 S @("ECXICD9"_I)=$G(ECXVIST("ICD9"_I))
-        ..S SOURCE=ECXVIST("SOURCE"),ECXAO=ECXVIST("AO"),ECXIR=ECXVIST("IR")
-        ..S ECXMIL=ECXVIST("MST"),ECXPROV=ECXVIST("PROV")
-        ..S ECPRNPI=$$NPI^XUSNPI("Individual_ID",ECXPROV,ECXDATE)
-        ..S:+ECPRNPI'>0 ECPRNPI="" S ECPRNPI=$P(ECPRNPI,U)
-        ..S ECXPROVP=ECXVIST("PROV CLASS"),ECXPROVN=ECXVIST("PROV NPI")
-        ..S ECXECE=ECXVIST("PGE"),ECXHNC=ECXVIST("HNC")
-        ..K LOCARR S DIC=8,DA=ECXENEL,DR="8",DIQ(0)="I",DIQ="LOCARR" D EN^DIQ1
-        ..S ECXENEL=+$G(LOCARR(8,ECXENEL,8,"I"))
-        ..S:ECXENEL ECXENEL=$$ELIG^ECXUTL3(ECXENEL,ECXSVC)
-        ..S ECXCBOC=$S(MDIV'="":$$CBOC^ECXSCX2(.MDIV),1:"")  ;is cboc facility?
-        ..;setup feeder key and file in extract records
-        ..S (ECXKEY,ECXDSSD)=""
-        ..;xray (105) or lab (108)
-        ..I (ECXSTOP=105)!(ECXSTOP=108) D  Q
-        ...S ECXKEY=ECXSTOP_"00003000000",ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY)
-        ...S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE       ;- Don't file rec if no encounter num
-        ..;appointments
-        ..I PROCESS=1 D  Q     ;get appt length
-        ...S (ALEN,JJ,OUT)=0
-        ...F  S JJ=$O(^SC(ECXCLIN,"S",ECXDATE,JJ)) Q:('JJ)!(OUT)  S K=0 D
-        ....F  S K=$O(^SC(ECXCLIN,"S",ECXDATE,JJ,K)) Q:('K)!(OUT)  D
-        .....S ECXOBI=$G(^SC(ECXCLIN,"S",ECXDATE,JJ,K,"OB")),PP=$P($G(^SC(ECXCLIN,"S",ECXDATE,JJ,K,0)),U)
-        .....S:PP=ECXDFN OUT=1,ALEN=$P(^(0),U,2),ALEN=$$RJ^XLFSTR(ALEN,3,0)
-        .....S:+ALEN=0 ALEN=$P($G(^TMP($J,"ECXCL",ECXCLIN)),U,2)
-        ....S ECXSTOP=P1
-        ....S PNODE=$G(^DPT(ECXDFN,"S",ECXDATE,0)),ECXPVST=$P(PNODE,U,7),ECXATYP=$P(PNODE,U,16)  ;Get purpose of visit & appt type
-        ....I TOSEND'=3 D
-        .....S ECXKEY=P1_P2_ALEN_P3_"0",ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY)
-        .....S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE
-        ....I TOSEND=3 D
-        .....S ECXKEY=P1_"000"_ALEN_P3_"0",ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY)
-        .....S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE
-        ....I TOSEND=3 D
-        .....S ECXKEY=P2_"000"_ALEN_P3_"0",ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY)
-        .....S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE
-        ..I PROCESS=2 D  Q
-        ...S ALEN=0
-        ...I SOURCE=TIU S ALEN=$P($G(^TMP($J,"ECXCL",ECXCLIN)),U,2)
-        ...S:+ALEN=0 ALEN="030" S ECXKEY=P1_P2_ALEN_P3_"0",ECXSTOP=P1
-        ...S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY)
-        ...S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE
-        ..;dispositions
-        ..I PROCESS=3 D  Q
-        ...S ECXKEY=ECXSTOP_"47906000000",ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY)
-        ...S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE
-        Q
-        ;
-FILE    ;record setup for file #727.827
-        N STR
-        S ECXPDIV=$$GETDIV^ECXDEPT(ECXDIV)  ; Get production division
-        S EC7=$O(^ECX(727.827,999999999),-1),EC7=EC7+1
-        S STR(0)=EC7_U_EC23_U_ECXDIV_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U
-        S STR(0)=STR(0)_$$ECXDATE^ECXUTL(ECXDATE,ECXYM)_U_ECXKEY_U_ECXOBI_U
-        ;convert specialty to PTF Code for transmission
-        N ECXDATA
-        S ECXDATA=$$TSDATA^DGACT(42.4,+ECXTS,.ECXDATA)
-        S ECXTS=$G(ECXDATA(7))
-        ;done
-        S STR(0)=STR(0)_ECXCLIN_U_ECXTS_U_ECXTI_U_ECPTTM_U_ECPTPR_U_ECCLAS_U
-        S STR(0)=STR(0)_ECXPROV_U_ECXPROVP_U_ECXCPT1_U_ECXCPT2_U_ECXCPT3_U
-        S STR(0)=STR(0)_ECXCPT4_U_ECXCPT5_U
-        S STR(1)=ECXCPT6_U_ECXCPT7_U_ECXCPT8_U_ECXICD9P_U_ECXICD91_U_ECXICD92_U
-        S STR(1)=STR(1)_ECXICD93_U_ECXICD94_U_ECXDOB_U_ECXELIG_U_ECXVET_U
-        S STR(1)=STR(1)_ECXRACE_U_ECXPST_U_ECXPLOC_U_ECXRST_U_ECXIR_U_ECXAST_U
-        S STR(1)=STR(1)_ECXAO_U_ECXMPI_U_ECXDSSD_U_ECXSEX_U_ECXZIP_U
-        S STR(1)=STR(1)_$G(ECXPCPNP)_U_U_ECXENEL_U_ECXMST_U
-        S STR(1)=STR(1)_ECXMIL_U_U_U_ECXENRL_U_ECXSTATE_U
-        S STR(1)=STR(1)_ECXCNTY_U_ECASPR_U_ECCLAS2_U_U_ECXDOM_U_ECXCAT_U
-        S STR(2)=ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXPHI_U_ECXPOS_U_ECXOBS_U_ECXENC_U
-        S STR(2)=STR(2)_ECXAOL_U_ECXPDIV_U_ECXATYP_U_ECXPVST_U_ECXMTST_U
-        S STR(2)=STR(2)_ECXHNCI_U_ECXETH_U_ECXRC1
-        I ECXLOGIC>2003 S STR(2)=STR(2)_U_ECXCBOC
-        I ECXLOGIC>2004 S STR(2)=STR(2)_U_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXNPRFI
-        I ECXLOGIC>2005 S STR(2)=STR(2)_U_ECXEST_U_ECXECE
-        I ECXLOGIC>2006 S STR(2)=STR(2)_U_ECXERI_U_ECXHNC
-        I ECXLOGIC>2007 S STR(2)=STR(2)_U_ECXOEF_U_ECXOEFDT_U_ECASNPI_U_ECPTNPI_U_$G(ECPRNPI)
-        D FILE2^ECXSCX2(727.827,EC7,.STR)
-        S ECRN=ECRN+1,$P(^ECX(727.827,0),U,3)=EC7
-        Q
-        ;
-SETUP   ;set required input for ECXTRAC
-        S ECHEAD="CLI"
-        D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
-        Q
+ECXSCXN ;ALB/JAP  Clinic Extract ; 4/19/2007
+ ;;3.0;DSS EXTRACTS;**24,27,29,30,31,32,33,39,46,49,52,71,84,92,107**;Dec 22, 1997;Build 9
+ ;
+BEG ;entry point from option
+ D SETUP Q:ECFILE=""  D ^ECXTRAC,^ECXKILL
+ Q
+ ;
+START ;entry point from taskmgr
+ N DIC,EXNUM,I,LOCARR,OUT,P1,P2,P3,PROCESS,SOURCE,STOP,STAT,TOSEND
+ N TIU,X,Y,ECXNPRFI
+ F I=1:1:8 S @("ECXCPT"_I)=""
+ F I=1:1:4 S @("ECXICD9"_I)=""
+ S (OUT,QFLG,ECRN)=0,(ECXICD9P,ECXOBI)=""
+ K ^TMP($J,"ECXS"),^TMP($J,"ECXCL")
+ ;get ien for tiu in file #839.7
+ S DIC="^PX(839.7,",DIC(0)="X",X="TEXT INTEGRATION UTILITIES"
+ D ^DIC S TIU=+Y,ECED=ECED+.3,ECXCLIN=0 K DIC,Y
+ ;get clinic default appt length, type, division
+ F  S ECXCLIN=$O(^SC(ECXCLIN)) Q:'ECXCLIN  D
+ .K LOCARR S DIC=44,DA=ECXCLIN,DR="2;3.5;1912",DIQ(0)="I",DIQ="LOCARR"
+ .D EN^DIQ1
+ .Q:$G(LOCARR(44,ECXCLIN,2,"I"))'="C"
+ .S ALEN=+$G(LOCARR(44,ECXCLIN,1912,"I"))
+ .S ^TMP($J,"ECXCL",ECXCLIN)=ALEN,ALEN=$$RJ^XLFSTR(ALEN,3,0)
+ .S ^TMP($J,"ECXCL",ECXCLIN)=^TMP($J,"ECXCL",ECXCLIN)_"^"_ALEN_"^"_$G(LOCARR(44,ECXCLIN,2,"I"))_"^"_+$G(LOCARR(44,ECXCLIN,3.5,"I"))
+ .D FEEDER^ECXSCX1(ECXCLIN,ECSD1,.P1,.P2,.P3,.TOSEND,.ECXDIV)
+ .K P1,P2,P3,TOSEND,ECXDIV
+ ;get from file #44 any no-shows & get encounters from #409.68
+ D NOSHOW^ECXSCXN1(ECSD1,ECED),ENCNTR(ECSD1,ECED)
+ ;send missing clinic msg
+ D:$D(^TMP($J,"ECXS")) EN^ECXSCX1
+ K ^TMP($J,"ECXS"),^TMP($J,"ECXCL")
+ Q
+ ;
+ENCNTR(ECSD1,ECED) ;search file #409.68 for encounter data
+ N CHKOUT,ECD,JJ,K,OUT,PNODE,PP,STAT,STOP,MDIV
+ S ECD=ECSD1
+ F  S ECD=$O(^SCE("B",ECD)) Q:('ECD!(ECD>ECED))!(QFLG)  S ECXIEN=0 D
+ .F  S ECXIEN=$O(^SCE("B",ECD,ECXIEN)) Q:'ECXIEN  D  Q:QFLG
+ ..Q:'$D(^SCE(ECXIEN,0))
+ ..D INTPAT^ECXSCX2 K LOCARR S DIC=409.68,DA=ECXIEN
+ ..S DR=".01;.02;.03;.04;.05;.06;.07;.08;.11;.12;.13",DIQ(0)="I",DIQ="LOCARR"
+ ..D EN^DIQ1
+ ..S ECXTI=$P($$FMTE^XLFDT(+$G(LOCARR(409.68,ECXIEN,.01,"I")),1),"@",2)
+ ..S ECXTI=$E(($TR(ECXTI,":","")_"000000"),1,6)
+ ..S:ECXTI="000000" ECXTI="000300" S MDIV=+$G(LOCARR(409.68,ECXIEN,.11,"I"))
+ ..S STOP=+$G(LOCARR(409.68,ECXIEN,.03,"I"))
+ ..S CHKOUT=+$G(LOCARR(409.68,ECXIEN,.07,"I"))
+ ..S PROCESS=+$G(LOCARR(409.68,ECXIEN,.08,"I"))
+ ..S STAT=$G(LOCARR(409.68,ECXIEN,.12,"I"))
+ ..S ECXDFN=+$G(LOCARR(409.68,ECXIEN,.02,"I"))
+ ..Q:(ECXDFN=0)!('CHKOUT)
+ ..S:STAT="" STAT="ZZ" S STAT=";"_STAT_";"
+ ..Q:";3;4;5;6;7;9;10;13;"[STAT
+ ..Q:('STOP)!(PROCESS=4)!(+$G(LOCARR(409.68,ECXIEN,.06,"I")))
+ ..S ECXDATE=+$G(LOCARR(409.68,ECXIEN,.01,"I"))
+ ..S ECXCLIN=+$G(LOCARR(409.68,ECXIEN,.04,"I"))
+ ..Q:$P($G(^TMP($J,"ECXCL",ECXCLIN)),U,3)'="C"
+ ..S ECXVISIT=+$G(LOCARR(409.68,ECXIEN,.05,"I"))
+ ..S ECXENEL=+$G(LOCARR(409.68,ECXIEN,.13,"I"))
+ ..Q:'ECXVISIT
+ ..S ECXERR=0
+ ..D PAT1^ECXSCX2(ECXDFN,ECXDATE,.ECXERR) Q:ECXERR
+ ..D FEEDER^ECXSCX1(ECXCLIN,ECSD1,.P1,.P2,.P3,.TOSEND,.ECXDIV)
+ ..Q:TOSEND=6
+ ..K LOCARR S DIC=40.7,DA=STOP,DR="1",DIQ(0)="I",DIQ="LOCARR" D EN^DIQ1
+ ..S ECXSTOP=$$RJ^XLFSTR($G(LOCARR(40.7,STOP,1,"I")),3,0)
+ ..;get date specific patient data
+ ..D PAT2^ECXSCX2(ECXDFN,ECXDATE)
+ ..;get national patient record flag if exist
+ ..D NPRF^ECXUTL5
+ ..;get visit specific data
+ ..S ECXERR=0 D VISIT^ECXSCX1(ECXDFN,ECXVISIT,.ECXVIST,.ECXERR) Q:ECXERR
+ ..F I=1:1:8 S @("ECXCPT"_I)=$G(ECXVIST("CPT"_I))
+ ..S ECXICD9P=$G(ECXVIST("ICD9P"))
+ ..F I=1:1:4 S @("ECXICD9"_I)=$G(ECXVIST("ICD9"_I))
+ ..S SOURCE=ECXVIST("SOURCE"),ECXAO=ECXVIST("AO"),ECXIR=ECXVIST("IR")
+ ..S ECXMIL=ECXVIST("MST"),ECXPROV=ECXVIST("PROV")
+ ..S ECXPROVP=ECXVIST("PROV CLASS"),ECXPROVN=ECXVIST("PROV NPI")
+ ..S ECXECE=ECXVIST("PGE"),ECXHNC=ECXVIST("HNC")
+ ..K LOCARR S DIC=8,DA=ECXENEL,DR="8",DIQ(0)="I",DIQ="LOCARR" D EN^DIQ1
+ ..S ECXENEL=+$G(LOCARR(8,ECXENEL,8,"I"))
+ ..S:ECXENEL ECXENEL=$$ELIG^ECXUTL3(ECXENEL,ECXSVC)
+ ..S ECXCBOC=$S(MDIV'="":$$CBOC^ECXSCX2(.MDIV),1:"")  ;is cboc facility?
+ ..;setup feeder key and file in extract records
+ ..S (ECXKEY,ECXDSSD)=""
+ ..;xray (105) or lab (108)
+ ..I (ECXSTOP=105)!(ECXSTOP=108) D  Q
+ ...S ECXKEY=ECXSTOP_"00003000000",ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY)
+ ...S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE       ;- Don't file rec if no encounter num
+ ..;appointments
+ ..I PROCESS=1 D  Q     ;get appt length
+ ...S (ALEN,JJ,OUT)=0
+ ...F  S JJ=$O(^SC(ECXCLIN,"S",ECXDATE,JJ)) Q:('JJ)!(OUT)  S K=0 D
+ ....F  S K=$O(^SC(ECXCLIN,"S",ECXDATE,JJ,K)) Q:('K)!(OUT)  D
+ .....S ECXOBI=$G(^SC(ECXCLIN,"S",ECXDATE,JJ,K,"OB")),PP=$P($G(^SC(ECXCLIN,"S",ECXDATE,JJ,K,0)),U)
+ .....S:PP=ECXDFN OUT=1,ALEN=$P(^(0),U,2),ALEN=$$RJ^XLFSTR(ALEN,3,0)
+ .....S:+ALEN=0 ALEN=$P($G(^TMP($J,"ECXCL",ECXCLIN)),U,2)
+ ....S ECXSTOP=P1
+ ....S PNODE=$G(^DPT(ECXDFN,"S",ECXDATE,0)),ECXPVST=$P(PNODE,U,7),ECXATYP=$P(PNODE,U,16)  ;Get purpose of visit & appt type
+ ....I TOSEND'=3 D
+ .....S ECXKEY=P1_P2_ALEN_P3_"0",ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY)
+ .....S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE
+ ....I TOSEND=3 D
+ .....S ECXKEY=P1_"000"_ALEN_P3_"0",ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY)
+ .....S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE
+ ....I TOSEND=3 D
+ .....S ECXKEY=P2_"000"_ALEN_P3_"0",ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY)
+ .....S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE
+ ..I PROCESS=2 D  Q
+ ...S ALEN=0
+ ...I SOURCE=TIU S ALEN=$P($G(^TMP($J,"ECXCL",ECXCLIN)),U,2)
+ ...S:+ALEN=0 ALEN="030" S ECXKEY=P1_P2_ALEN_P3_"0",ECXSTOP=P1
+ ...S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY)
+ ...S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE
+ ..;dispositions
+ ..I PROCESS=3 D  Q
+ ...S ECXKEY=ECXSTOP_"47906000000",ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY)
+ ...S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE
+ Q
+ ;
+FILE ;record setup for file #727.827
+ N STR
+ S ECXPDIV=$$GETDIV^ECXDEPT(ECXDIV)  ; Get production division
+ S EC7=$O(^ECX(727.827,999999999),-1),EC7=EC7+1
+ S STR(0)=EC7_U_EC23_U_ECXDIV_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U
+ S STR(0)=STR(0)_$$ECXDATE^ECXUTL(ECXDATE,ECXYM)_U_ECXKEY_U_ECXOBI_U
+ ;convert specialty to PTF Code for transmission
+ N ECXDATA
+ S ECXDATA=$$TSDATA^DGACT(42.4,+ECXTS,.ECXDATA)
+ S ECXTS=$G(ECXDATA(7))
+ ;done
+ S STR(0)=STR(0)_ECXCLIN_U_ECXTS_U_ECXTI_U_ECPTTM_U_ECPTPR_U_ECCLAS_U
+ S STR(0)=STR(0)_ECXPROV_U_ECXPROVP_U_ECXCPT1_U_ECXCPT2_U_ECXCPT3_U
+ S STR(0)=STR(0)_ECXCPT4_U_ECXCPT5_U
+ S STR(1)=ECXCPT6_U_ECXCPT7_U_ECXCPT8_U_ECXICD9P_U_ECXICD91_U_ECXICD92_U
+ S STR(1)=STR(1)_ECXICD93_U_ECXICD94_U_ECXDOB_U_ECXELIG_U_ECXVET_U
+ S STR(1)=STR(1)_ECXRACE_U_ECXPST_U_ECXPLOC_U_ECXRST_U_ECXIR_U_ECXAST_U
+ S STR(1)=STR(1)_ECXAO_U_ECXMPI_U_ECXDSSD_U_ECXSEX_U_ECXZIP_U
+ S STR(1)=STR(1)_$G(ECXPCPNP)_U_$G(ECXNPIPR)_U_ECXENEL_U_ECXMST_U
+ S STR(1)=STR(1)_ECXMIL_U_U_U_ECXENRL_U_ECXSTATE_U
+ S STR(1)=STR(1)_ECXCNTY_U_ECASPR_U_ECCLAS2_U_ECASNPI_U_ECXDOM_U_ECXCAT_U
+ S STR(2)=ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXPHI_U_ECXPOS_U_ECXOBS_U_ECXENC_U
+ S STR(2)=STR(2)_ECXAOL_U_ECXPDIV_U_ECXATYP_U_ECXPVST_U_ECXMTST_U
+ S STR(2)=STR(2)_ECXHNCI_U_ECXETH_U_ECXRC1
+ I ECXLOGIC>2003 S STR(2)=STR(2)_U_ECXCBOC
+ I ECXLOGIC>2004 S STR(2)=STR(2)_U_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXNPRFI
+ I ECXLOGIC>2005 S STR(2)=STR(2)_U_ECXEST_U_ECXECE
+ I ECXLOGIC>2006 S STR(2)=STR(2)_U_ECXERI_U_ECXHNC
+ D FILE2^ECXSCX2(727.827,EC7,.STR)
+ S ECRN=ECRN+1,$P(^ECX(727.827,0),U,3)=EC7
+ Q
+ ;
+SETUP ;set required input for ECXTRAC
+ S ECHEAD="CLI"
+ D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
+ Q

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXSCXN1.m

@@ -1 @@
-ECXSCXN1        ;ALB/JAP  Clinic Extract No Shows; 8/28/02 1:11pm ; 9/6/07 3:17pm
-        ;;3.0;DSS EXTRACTS;**71,105**;Dec 22, 1997;Build 70
-NOSHOW(ECXSD,ECXED)     ;get noshows from file #44
-        ;      ECXSD  = start date, ECXED  = end date
-        N ALEN,CLIN,JDATE,JJ,NODE,NOSHOW,PP,STAT,MDIV
-        S CLIN=0
-        F  S CLIN=$O(^TMP($J,"ECXCL",CLIN)) Q:'CLIN  D
-        .Q:$P($G(^TMP($J,"ECXCL",CLIN)),U,3)'="C"
-        .S (P1,P2,P3)=""
-        .D FEEDER^ECXSCX1(CLIN,ECXSD,.P1,.P2,.P3,.TOSEND,.ECXDIV)
-        .Q:TOSEND=6
-        .;find appts in date range
-        .S JDATE=ECXSD,(ALEN,NOSHOW)=""
-        .F  S JDATE=$O(^SC(CLIN,"S",JDATE)) Q:'JDATE  Q:JDATE>ECXED  D
-        ..S ECXDATE=JDATE,JJ=0,ECXTI=$P($$FMTE^XLFDT(JDATE,1),"@",2)
-        ..S ECXTI=$E(($TR(ECXTI,":","")_"000000"),1,6)
-        ..S:ECXTI="000000" ECXTI="000300"
-        ..;get noshows only - no data in check-in/check-out node
-        ..F  S JJ=$O(^SC(CLIN,"S",JDATE,JJ)) Q:'JJ  D
-        ...S K=0
-        ...F  S K=$O(^SC(CLIN,"S",JDATE,JJ,K)) Q:'K  D
-        ....S PP=$G(^SC(CLIN,"S",JDATE,JJ,K,0)),ECXDFN=$P(PP,U) Q:ECXDFN=""
-        ....S NODE=$G(^DPT(ECXDFN,"S",JDATE,0)),MDIV=$P($G(^SC(CLIN,0)),U,15)
-        ....Q:(NODE="")!($P(NODE,U)'=CLIN)
-        ....S ECXOBI=$G(^SC(CLIN,"S",JDATE,JJ,K,"OB")),STAT=$P(NODE,U,2)
-        ....S NOSHOW=$S(STAT="N":"N",STAT="NA":"N",1:"")
-        ....Q:NOSHOW=""  D INTPAT^ECXSCX2 S ECXERR=0
-        ....D PAT1^ECXSCX2(ECXDFN,ECXDATE,.ECXERR) Q:ECXERR
-        ....S ALEN=$P(PP,U,2),ALEN=$$RJ^XLFSTR(ALEN,3,0)
-        ....D PAT2^ECXSCX2(ECXDFN,ECXDATE)
-        ....S ECXPVST=$P(NODE,U,7),ECXATYP=$P(NODE,U,16)  ;Get POV & appt type
-        ....S:+ALEN=0 ALEN=$P($G(^TMP($J,"ECXCL",CLIN)),U,2)
-        ....S ECXCLIN=CLIN,ECXSTOP=P1
-        ....S:ECXCPT1="" ECXCPT1="9919901"
-        ....S ECXCBOC=$S(MDIV'="":$$CBOC^ECXSCX2(.MDIV),1:"")
-        ....S (ECXDSSD,ECXENEL,ECXIR,ECXAO,ECXMIL,ECXPROV,ECXPROVP,ECXPROVN)=""
-        ....I TOSEND'=3 D
-        .....S ECXKEY=P1_P2_ALEN_P3_NOSHOW,ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY)
-        .....S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE^ECXSCXN
-        ....I TOSEND=3 D
-        .....S ECXKEY=P1_"000"_ALEN_P3_NOSHOW,ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY)
-        .....S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE^ECXSCXN
-        ....I TOSEND=3 D
-        .....S ECXKEY=P2_"000"_ALEN_P3_NOSHOW,ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY)
-        .....S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE^ECXSCXN
-        ....;create a record for noshow appended ekg. The code was removed for CTX-0604-70970 CLI Extract Problem EXPANDED to NoShows
-        Q
+ECXSCXN1 ;ALB/JAP  Clinic Extract No Shows; 8/28/02 1:11pm ; 10/26/04 10:35am
+ ;;3.0;DSS EXTRACTS;**71**;Dec 22, 1997
+NOSHOW(ECXSD,ECXED) ;get noshows from file #44
+ ;      ECXSD  = start date, ECXED  = end date
+ N ALEN,CLIN,JDATE,JJ,NODE,NOSHOW,PP,STAT,MDIV
+ S CLIN=0
+ F  S CLIN=$O(^TMP($J,"ECXCL",CLIN)) Q:'CLIN  D
+ .Q:$P($G(^TMP($J,"ECXCL",CLIN)),U,3)'="C"
+ .S (P1,P2,P3)=""
+ .D FEEDER^ECXSCX1(CLIN,ECXSD,.P1,.P2,.P3,.TOSEND,.ECXDIV)
+ .Q:TOSEND=6
+ .;find appts in date range
+ .S JDATE=ECXSD,(ALEN,NOSHOW)=""
+ .F  S JDATE=$O(^SC(CLIN,"S",JDATE)) Q:'JDATE  Q:JDATE>ECXED  D
+ ..S ECXDATE=JDATE,JJ=0,ECXTI=$P($$FMTE^XLFDT(JDATE,1),"@",2)
+ ..S ECXTI=$E(($TR(ECXTI,":","")_"000000"),1,6)
+ ..S:ECXTI="000000" ECXTI="000300"
+ ..;get noshows only - no data in check-in/check-out node
+ ..F  S JJ=$O(^SC(CLIN,"S",JDATE,JJ)) Q:'JJ  D
+ ...S K=0
+ ...F  S K=$O(^SC(CLIN,"S",JDATE,JJ,K)) Q:'K  D
+ ....S PP=$G(^SC(CLIN,"S",JDATE,JJ,K,0)),ECXDFN=$P(PP,U) Q:ECXDFN=""
+ ....S NODE=$G(^DPT(ECXDFN,"S",JDATE,0)),MDIV=$P($G(^SC(CLIN,0)),U,15)
+ ....Q:(NODE="")!($P(NODE,U)'=CLIN)
+ ....S ECXOBI=$G(^SC(CLIN,"S",JDATE,JJ,K,"OB")),STAT=$P(NODE,U,2)
+ ....S NOSHOW=$S(STAT="N":"N",STAT="NA":"N",1:"")
+ ....Q:NOSHOW=""  D INTPAT^ECXSCX2 S ECXERR=0
+ ....D PAT1^ECXSCX2(ECXDFN,ECXDATE,.ECXERR) Q:ECXERR
+ ....S ALEN=$P(PP,U,2),ALEN=$$RJ^XLFSTR(ALEN,3,0)
+ ....D PAT2^ECXSCX2(ECXDFN,ECXDATE)
+ ....S ECXPVST=$P(NODE,U,7),ECXATYP=$P(NODE,U,16)  ;Get POV & appt type
+ ....S:+ALEN=0 ALEN=$P($G(^TMP($J,"ECXCL",CLIN)),U,2)
+ ....S ECXCLIN=CLIN,ECXSTOP=P1 S:ECXICD9P="" ECXICD9P="799.9"
+ ....S:ECXCPT1="" ECXCPT1="9919901"
+ ....S ECXCBOC=$S(MDIV'="":$$CBOC^ECXSCX2(.MDIV),1:"")
+ ....S (ECXDSSD,ECXENEL,ECXIR,ECXAO,ECXMIL,ECXPROV,ECXPROVP,ECXPROVN)=""
+ ....I TOSEND'=3 D
+ .....S ECXKEY=P1_P2_ALEN_P3_NOSHOW,ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY)
+ .....S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE^ECXSCXN
+ ....I TOSEND=3 D
+ .....S ECXKEY=P1_"000"_ALEN_P3_NOSHOW,ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY)
+ .....S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE^ECXSCXN
+ ....I TOSEND=3 D
+ .....S ECXKEY=P2_"000"_ALEN_P3_NOSHOW,ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY)
+ .....S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE^ECXSCXN
+ ....;create a record for noshow appended ekg. The code was removed for CTX-0604-70970 CLI Extract Problem EXPANDED to NoShows
+ Q

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXSURG.m

@@ -1 @@
-ECXSURG ;ALB/JA,BIR/DMA,PTD-Surgery Extract for DSS ; 11/20/07 8:13am
-        ;;3.0;DSS EXTRACTS;**1,11,8,13,25,24,33,39,41,42,46,50,71,84,92,99,105**;Dec 22, 1997;Build 70
-BEG     ;entry point from option
-        D SETUP I ECFILE="" Q
-        D ^ECXTRAC,^ECXKILL
-        Q
-        ;
-START   ;
-        S QFLG=0,ECED=ECED+.3,ECD=ECSD1
-        F  S ECD=$O(^SRF("AC",ECD)),ECD0=0 Q:('ECD)!(ECD>ECED)!(QFLG)  D
-        .F  S ECD0=$O(^SRF("AC",ECD,ECD0)) Q:'ECD0  D
-        ..I $D(^SRF(ECD0,0)) S EC=^SRF(ECD0,0),ECXDFN=+$P(EC,U),ECXVISIT=$P(EC,U,15) D STUFF Q:QFLG
-        Q
-        ;
-STUFF   ;gather data
-        N J,X,Y,PP,DATA1,DATA2,DATAOP,ARR,ERR,SUB,MOD,ECXNONL,ECXSTOP,TIMEDIF
-        N ECPRO,ECXORCT,ECXPTHA,ECXNPRFI,ECXPA,ECXPAPC,ECSRPC,ECATPC,ECSAPC
-        N ECXCRST,ECXSTCD,ECXCLIN
-        S ECXDATE=ECD,ECXERR=0,ECXQ=""
-        Q:'$$PATDEM^ECXUTL2(ECXDFN,ECXDATE,"1;2;3;5;")
-        I ECXADMDT="" S ECXADD=ECXADMDT
-        I ECXADMDT'="" S ECXADD=$$ECXDATE^ECXUTL(ECXADMDT,ECXYM)
-        S OK=$$PAT^ECXUTL3(ECXDFN,ECXDATE,"1;5",.ECXPAT)
-        I 'OK S ECXERR=1 K ECXPAT Q
-        ;OEF/OIF DATA
-        S ECXOEF=ECXPAT("ECXOEF")
-        S ECXOEFDT=ECXPAT("ECXOEFDT")
-        S EC0=^SRF(ECD0,0)
-        S DATA1=$S($D(^SRF(ECD0,.1)):^(.1),1:"")
-        S DATA2=$S($D(^SRF(ECD0,.2)):^(.2),1:"")
-        S DATAOP=$S($D(^SRO(136,ECD0,0)):^(0),1:"")
-        S ECNO=$G(^SRF(ECD0,"NON"))
-        ;get data
-        S ECSR=$P(DATA1,U,4),(ECATNPI,ECSANPI,ECSRNPI)="",ECAT=$P(DATA1,U,13)
-        S ECSRNPI=$$NPI^XUSNPI("Individual_ID",ECSR,ECXDATE)
-        S:+ECSRNPI'>0 ECSRNPI="" S ECSRNPI=$P(ECSRNPI,U)
-        ;-Time patient in OR room (Nurse Time)
-        S ECXTM=$$ECXTIME^ECXUTL($P(DATA2,U,10))
-        S ECXDIV=$S($D(^SRF(ECD0,8)):^(8),1:ECINST)
-        N ECXPDIV S ECXPDIV=$$RADDIV^ECXDEPT(ECXDIV)  ;Production Division
-        S ECSA=$P($G(^SRF(ECD0,.3)),U,4),ECO=$P(EC0,U,2)
-        S ECSANPI=$$NPI^XUSNPI("Individual_ID",ECSA,ECXDATE)
-        S:+ECSANPI'>0 ECSANPI="" S ECSANPI=$P(ECSANPI,U)
-        ;get principle anesthetist and person class DBIA #103
-        S ECXPA=$P($G(^SRF(ECD0,.3)),U,1)
-        S ECPANPI=$$NPI^XUSNPI("Individual_ID",ECXPA,ECXDATE)
-        S:+ECPANPI'>0 ECPANPI="" S ECPANPI=$P(ECPANPI,U)
-        S ECXPAPC=$$PRVCLASS^ECXUTL(ECXPA,ECXDATE)
-        S ECORTY=$P($G(^SRS(+ECO,2)),U),ECO=$P($G(^SRS(+ECO,0)),U)
-        S ECSS=$P($G(^SRO(137.45,+$P(EC0,U,4),0)),U,2)
-        S ECSS=$$RJ^XLFSTR($P($G(^DIC(45.3,+ECSS,0)),U),3,0)
-        S:ECSS="000" ECSS="999"
-        ;get classification information
-        S (ECXAO,ECXHNC)="" I ECXVISIT'="" D
-        .D VISIT^ECXSCX1(ECXDFN,ECXVISIT,.ECXVIST,.ECXERR) I ECXERR K ECXERR
-        .S ECXAO=$G(ECXVIST("AO")),ECXHNC=$G(ECXVIST("HNC"))
-        ; - Head and Neck Cancer Indicator
-        S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN)
-        ;look for non-OR
-        S (ECNT,ECNL,ECXDSSD,ECXNONL,ECXSTOP)=""
-        I $P(ECNO,U)="Y" D
-        .S ECSR=$P(ECNO,U,6),ECAT=$P(ECNO,U,7)
-        .S ECSRNPI=$$NPI^XUSNPI("Individual_ID",ECSR,ECXDATE)
-        .S:+ECSRNPI'>0 ECSRNPI="" S ECSRNPI=$P(ECSRNPI,U)
-        .S ECATNPI=$$NPI^XUSNPI("Individual_ID",ECAT,ECXDATE)
-        .S:+ECATNPI'>0 ECATNPI="" S ECATNPI=$P(ECATNPI,U)
-        .S ECXTM=$$ECXTIME^ECXUTL($P(ECNO,U,4))
-        .S A1=$P(ECNO,U,5),A2=$P(ECNO,U,4),TIME="##" D:(A1&A2) TIME S ECNT=TIME
-        .S (ECXNONL,ECNL)=+$P(ECNO,U,2),ECNL=$P($G(^ECX(728.44,ECNL,0)),U,9)
-        .S:ECNL="" ECNL="UNKNOWN"
-        .;
-        .;- Get DSS Stop Code to use in encounter number
-        .S ECXSTOP=$P($G(^ECX(728.44,ECXNONL,0)),U,4)
-        ;
-        ;- Get credit stop, stop code and clinic
-        I $$SUR^ECXUTL6(.ECXCRST,.ECXSTCD,.ECXCLIN)
-        ;
-        ;- If surgery cancelled/aborted quit and go to next record
-        S ECCAN=$P($G(^SRF(ECD0,30)),U)
-        I +ECCAN S ECCAN=$$CANC^ECXUTL4(ECNL,$P(DATA2,U,10))
-        ;on hold for ECXDSSD and ECXDSSP I $P($G(^SRF(ECD0,30)),U) Q
-        ;get service of attending surgeon
-        S ECATSV=$P($G(^DIC(49,+$G(^VA(200,+ECAT,5)),730)),U)
-        ;
-        ;get surgeon, attending and anesthesia super person classes
-        S ECSRPC=$$PRVCLASS^ECXUTL(ECSR,ECXDATE)
-        S ECATPC=$$PRVCLASS^ECXUTL(ECAT,ECXDATE)
-        S ECSAPC=$$PRVCLASS^ECXUTL(ECSA,ECXDATE)
-        ;
-        ;add leading 2s for pointer to 200
-        S:ECAT ECAT="2"_ECAT S:ECSR ECSR="2"_ECSR S:ECSA ECSA="2"_ECSA
-        ;add leading 2 to principle anesthetist IEN
-        S:ECXPA ECXPA="2"_ECXPA
-        ;anesthesia technique
-        S ECANE="",PP=""
-        I $D(^SRF(ECD0,6,0)) S ECXJ=0 D
-        .F  S ECXJ=$O(^SRF(ECD0,6,ECXJ)) Q:('ECXJ)!(ECANE]"")  D
-        ..S PP=$P($G(^(ECXJ,0)),U,3) S:PP="Y" ECANE=$P(^(0),U,1)
-        .I ECANE="" S ECXJ=$O(^SRF(ECD0,6,0)) I ECXJ S ECANE=$P(^SRF(ECD0,6,ECXJ,0),U,1)
-        ;get primary procedure
-        ;ecode0=p^cpt code^^patient time^operation time^anesthesia time
-        S ECPT=+$P(DATAOP,U,2),ECXCMOD=""
-        K ARR,ERR D FIELD^DID(130,28,,"LABEL","ARR","ERR") I $D(ARR("LABEL")) D
-        .K ARR,ERR D FIELD^DID(130,28,,"GLOBAL SUBSCRIPT LOCATION","ARR","ERR")
-        .Q:$D(ERR("DIERR"))
-        .S SUB=$P(ARR("GLOBAL SUBSCRIPT LOCATION"),";"),MOD=0
-        .F  S MOD=$O(^SRF(ECD0,SUB,MOD)) Q:MOD'>0  D
-        ..S ECXCMOD=ECXCMOD_$P(^(MOD,0),U)_";"
-        S ECXCPT=$$CPT^ECXUTL3(ECPT,ECXCMOD)
-        S ECODE0="P"_U_U  ;ECPT_U
-        F J="10,12","2,3","1,4" D
-        .N ECNTIME,ECSTIME,ECATIME
-        .S A2=$P(DATA2,U,$P(J,",")),A1=$P(DATA2,U,$P(J,",",2)),TIME="##"
-        .I (A1&A2)&(+J=10) D TIME  S ECNTIME=TIME
-        .I (A1&A2)&(+J=1) D TIME  S ECATIME=TIME
-        .I (A1&A2)&(+J=2) D
-        ..;
-        ..;-Operation Time (Surgeon Time)
-        ..;-Get time diff (in secs) & set to .5 if < 7.5 minutes (rounds to 1)
-        ..S TIMEDIF=$$FMDIFF^XLFDT(A1,A2,2)/900
-        ..S TIMEDIF=$S(TIMEDIF>0&(TIMEDIF<.5):.5,1:TIMEDIF)
-        ..S TIME=$TR($J(TIMEDIF,4,0)," ")
-        ..S:TIME<0 TIME="###"
-        ..S:TIME ECSTIME=TIME
-        .S ECODE0=ECODE0_U_TIME K TIME
-        ; -Recovery Room Time
-        S ECRR=""
-        I $D(^SRF(ECD0,1.1)) D
-        .S A1=$P(^(1.1),U,8),A2=$P(^(1.1),U,7),TIME="##" D:(A1&A2) TIME
-        .S ECRR=TIME K TIME
-        I ECNL]"" S $P(ECODE0,U,5)=ECNT
-        ;
-        ; -OR Clean Time in 15 min increments DBIA #103
-        S ECXORCT=($$FMDIFF^XLFDT($P($G(DATA2),U,14),$P($G(DATA2),U,13),2)/60)/15
-        ; -If no OR clean time recorded set it to 2
-        I ECXORCT'>0 S ECXORCT=2
-        ;
-        ; -PT in hold area time in 15 min increments DBIA #103
-        I $P($G(DATA2),U,10),$P($G(DATA2),U,15) D
-        .S ECXPTHA=($$FMDIFF^XLFDT($P($G(DATA2),U,10),$P($G(DATA2),U,15),2)/60)/15
-        .S CON=$P($G(^SRF(ECD0,"CON")),U)
-        .I CON S ECXPTHA=ECXPTHA/2
-        .S ECXPTHA=$TR($J(ECXPTHA,3,0)," ")
-        ; -If hold time is =<0 set it to ""
-        S:$G(ECXPTHA)'>0 ECXPTHA=""
-        ;
-        ;- Observation Patient Indicator (yes/no)
-        S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECNL)
-        ;
-        ;- set national patient record flag if exist
-        D NPRF^ECXUTL5
-        ;
-        ;- If no encounter number don't file record
-        S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXSTOP,ECSS) Q:ECXENC=""
-        ;
-        ;- Get postop diagnosis codes
-        I $$SURPODX^ECXUTL6(.ECXPODX,.ECXPODX1,.ECXPODX2,.ECXPODX3,.ECXPODX4,.ECXPODX5)
-        ;
-        D FILE^ECXSURG1
-        ;get secondary procedures
-        ;ecode0=s^cpt code
-        S ECXJ=0
-        F  S ECXJ=$O(^SRO(136,ECD0,3,ECXJ)) Q:'ECXJ  I $D(^(ECXJ,0)),$D(^(0)),$P(^(0),"^")]"" D
-        .;S ECPT=$P(^SRF(ECD0,13,ECXJ,2),U),ECXCMOD=""
-        .S ECPT=$P(^SRO(136,ECD0,3,ECXJ,0),U),ECXMOD=""
-        .S ECPT=$P(^(0),"^"),ECXCMOD=""
-        .K ARR,ERR
-        .D FIELD^DID(130.16,4,,"LABEL","ARR","ERR") I $D(ARR("LABEL")) D
-        ..K ARR,ERR
-        ..D FIELD^DID(130.16,4,,"GLOBAL SUBSCRIPT LOCATION","ARR","ERR")
-        ..Q:$D(ERR("DIERR"))
-        ..S SUB=$P(ARR("GLOBAL SUBSCRIPT LOCATION"),";"),MOD=0
-        ..F  S MOD=$O(^SRF(ECD0,13,ECXJ,SUB,MOD)) Q:MOD'>0  S ECXCMOD=ECXCMOD_$P(^(MOD,0),U)_";"
-        .S ECXCPT=$$CPT^ECXUTL3(ECPT,ECXCMOD)
-        .S ECODE0="S"_U   ;_ECPT
-        .D FILE^ECXSURG1
-        ;get prostheses
-        ;ecode0=i^^^^^^prosthesis^old qty field (null)
-        S ECXJ=0
-        F  S ECXJ=$O(^SRF(ECD0,1,ECXJ)) Q:'ECXJ  I $D(^(ECXJ,0)) D
-        .S ECXP=+^SRF(ECD0,1,ECXJ,0),ECXQ=$P($G(^(1)),U,2) S:'ECXQ ECXQ=1
-        .S ECODE0="I"_U_U_U_U_U_U_ECXP_U_U
-        .D FILE^ECXSURG1
-        Q
-        ;
-        ;
-TIME    ; given date/time get increment
-        ;A1=later, A2=earlier, TIME=difference
-        N CON,TIMEDIF
-        S CON=$P($G(^SRF(ECD0,"CON")),U)
-        ;
-        ;-Get time diff (in secs) & set to .5 if < 7.5 minutes (rounds to 1)
-        S TIMEDIF=$$FMDIFF^XLFDT(A1,A2,2)/900
-        S TIMEDIF=$S(TIMEDIF>0&(TIMEDIF<.5):.5,1:TIMEDIF)
-        I 'CON D
-        .S TIME=$J($TR($J(TIMEDIF,4,0)," "),2,1)
-        .S:TIME>"99.0" TIME="99.0"
-        I CON D
-        .S TIME=$J(($TR($J(TIMEDIF,4,0)," ")/2),2,1)
-        .S:TIME>"99.5" TIME="99.5"
-        S:TIME<0 TIME="###"
-        Q
-        ;
-SETUP   ;Set required input for ECXTRAC
-        S ECHEAD="SUR"
-        D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
-        Q
-        ;
-QUE     ; entry point for the background requeuing handled by ECXTAUTO
-        D SETUP,QUE^ECXTAUTO,^ECXKILL Q
+ECXSURG ;ALB/JA,BIR/DMA,PTD-Surgery Extract for DSS ; 11/2/06 9:00am
+ ;;3.0;DSS EXTRACTS;**1,11,8,13,25,24,33,39,41,42,46,50,71,84,92,99**;Dec 22, 1997;Build 2
+BEG ;entry point from option
+ D SETUP I ECFILE="" Q
+ D ^ECXTRAC,^ECXKILL
+ Q
+ ;
+START ;
+ S QFLG=0,ECED=ECED+.3,ECD=ECSD1
+ F  S ECD=$O(^SRF("AC",ECD)),ECD0=0 Q:('ECD)!(ECD>ECED)!(QFLG)  D
+ .F  S ECD0=$O(^SRF("AC",ECD,ECD0)) Q:'ECD0  D
+ ..I $D(^SRF(ECD0,0)) S EC=^SRF(ECD0,0),ECXDFN=+$P(EC,U),ECXVISIT=$P(EC,U,15) D STUFF Q:QFLG
+ Q
+ ;
+STUFF ;gather data
+ N J,X,Y,PP,DATA1,DATA2,DATAOP,ARR,ERR,SUB,MOD,ECXNONL,ECXSTOP,TIMEDIF
+ N ECPRO,ECXORCT,ECXPTHA,ECXNPRFI,ECXPA,ECXPAPC,ECSRPC,ECATPC,ECSAPC
+ S ECXDATE=ECD,ECXERR=0,ECXQ=""
+ Q:'$$PATDEM^ECXUTL2(ECXDFN,ECXDATE,"1;2;3;5;")
+ I ECXADMDT="" S ECXADD=ECXADMDT
+ I ECXADMDT'="" S ECXADD=$$ECXDATE^ECXUTL(ECXADMDT,ECXYM)
+ S EC0=^SRF(ECD0,0)
+ S DATA1=$S($D(^SRF(ECD0,.1)):^(.1),1:"")
+ S DATA2=$S($D(^SRF(ECD0,.2)):^(.2),1:"")
+ ;S DATAOP=$S($D(^SRF(ECD0,"OP")):^("OP"),1:"")
+ S DATAOP=$S($D(^SRO(136,ECD0,0)):^(0),1:"")
+ S ECNO=$G(^SRF(ECD0,"NON"))
+ ;get data
+ S ECSR=$P(DATA1,U,4),(ECATNPI,ECSANPI,ECSRNPI)="",ECAT=$P(DATA1,U,13)
+ ;-Time patient in OR room (Nurse Time)
+ S ECXTM=$$ECXTIME^ECXUTL($P(DATA2,U,10))
+ S ECXDIV=$S($D(^SRF(ECD0,8)):^(8),1:ECINST)
+ N ECXPDIV S ECXPDIV=$$RADDIV^ECXDEPT(ECXDIV)  ;Production Division
+ S ECSA=$P($G(^SRF(ECD0,.3)),U,4),ECO=$P(EC0,U,2)
+ ;get principle anesthetist and person class DBIA #103
+ S ECXPA=$P($G(^SRF(ECD0,.3)),U,1)
+ S ECXPAPC=$$PRVCLASS^ECXUTL(ECXPA,ECXDATE)
+ S ECORTY=$P($G(^SRS(+ECO,2)),U),ECO=$P($G(^SRS(+ECO,0)),U)
+ S ECSS=$P($G(^SRO(137.45,+$P(EC0,U,4),0)),U,2)
+ S ECSS=$$RJ^XLFSTR($P($G(^DIC(45.3,+ECSS,0)),U),3,0)
+ S:ECSS="000" ECSS="999"
+ ;get classification information
+ S (ECXAO,ECXHNC)="" I ECXVISIT'="" D
+ .D VISIT^ECXSCX1(ECXDFN,ECXVISIT,.ECXVIST,.ECXERR) I ECXERR K ECXERR
+ .S ECXAO=$G(ECXVIST("AO")),ECXHNC=$G(ECXVIST("HNC"))
+ ; - Head and Neck Cancer Indicator
+ S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN)
+ ;look for non-OR
+ S (ECNT,ECNL,ECXDSSD,ECXNONL,ECXSTOP)=""
+ I $P(ECNO,U)="Y" D
+ .S ECSR=$P(ECNO,U,6),ECAT=$P(ECNO,U,7)
+ .S ECXTM=$$ECXTIME^ECXUTL($P(ECNO,U,4))
+ .S A1=$P(ECNO,U,5),A2=$P(ECNO,U,4),TIME="##" D:(A1&A2) TIME S ECNT=TIME
+ .S (ECXNONL,ECNL)=+$P(ECNO,U,2),ECNL=$P($G(^ECX(728.44,ECNL,0)),U,9)
+ .S:ECNL="" ECNL="UNKNOWN"
+ .;
+ .;- Get DSS Stop Code to use in encounter number
+ .S ECXSTOP=$P($G(^ECX(728.44,ECXNONL,0)),U,4)
+ ;
+ ;- If surgery cancelled/aborted quit and go to next record
+ S ECCAN=$P($G(^SRF(ECD0,30)),U)
+ I +ECCAN S ECCAN=$$CANC^ECXUTL4(ECNL,$P(DATA2,U,10))
+ ;on hold for ECXDSSD and ECXDSSP I $P($G(^SRF(ECD0,30)),U) Q
+ ;get service of attending surgeon
+ S ECATSV=$P($G(^DIC(49,+$G(^VA(200,+ECAT,5)),730)),U)
+ ;
+ ;get surgeon, attending and anesthesia super person classes
+ S ECSRPC=$$PRVCLASS^ECXUTL(ECSR,ECXDATE)
+ S ECATPC=$$PRVCLASS^ECXUTL(ECAT,ECXDATE)
+ S ECSAPC=$$PRVCLASS^ECXUTL(ECSA,ECXDATE)
+ ;
+ ;add leading 2s for pointer to 200
+ S:ECAT ECAT="2"_ECAT S:ECSR ECSR="2"_ECSR S:ECSA ECSA="2"_ECSA
+ ;add leading 2 to principle anesthetist IEN
+ S:ECXPA ECXPA="2"_ECXPA
+ ;anesthesia technique
+ S ECANE="",PP=""
+ I $D(^SRF(ECD0,6,0)) S ECXJ=0 D
+ .F  S ECXJ=$O(^SRF(ECD0,6,ECXJ)) Q:('ECXJ)!(ECANE]"")  D
+ ..S PP=$P($G(^(ECXJ,0)),U,3) S:PP="Y" ECANE=$P(^(0),U,1)
+ .I ECANE="" S ECXJ=$O(^SRF(ECD0,6,0)) I ECXJ S ECANE=$P(^SRF(ECD0,6,ECXJ,0),U,1)
+ ;get primary procedure
+ ;ecode0=p^cpt code^^patient time^operation time^anesthesia time
+ S ECPT=+$P(DATAOP,U,2),ECXCMOD=""
+ K ARR,ERR D FIELD^DID(130,28,,"LABEL","ARR","ERR") I $D(ARR("LABEL")) D
+ .K ARR,ERR D FIELD^DID(130,28,,"GLOBAL SUBSCRIPT LOCATION","ARR","ERR")
+ .Q:$D(ERR("DIERR"))
+ .S SUB=$P(ARR("GLOBAL SUBSCRIPT LOCATION"),";"),MOD=0
+ .F  S MOD=$O(^SRF(ECD0,SUB,MOD)) Q:MOD'>0  D
+ ..S ECXCMOD=ECXCMOD_$P(^(MOD,0),U)_";"
+ S ECXCPT=$$CPT^ECXUTL3(ECPT,ECXCMOD)
+ S ECODE0="P"_U_U  ;ECPT_U
+ F J="10,12","2,3","1,4" D
+ .N ECNTIME,ECSTIME,ECATIME
+ .S A2=$P(DATA2,U,$P(J,",")),A1=$P(DATA2,U,$P(J,",",2)),TIME="##"
+ .I (A1&A2)&(+J=10) D TIME  S ECNTIME=TIME
+ .I (A1&A2)&(+J=1) D TIME  S ECATIME=TIME
+ .I (A1&A2)&(+J=2) D
+ ..;
+ ..;-Operation Time (Surgeon Time)
+ ..;-Get time diff (in secs) & set to .5 if < 7.5 minutes (rounds to 1)
+ ..S TIMEDIF=$$FMDIFF^XLFDT(A1,A2,2)/900
+ ..S TIMEDIF=$S(TIMEDIF>0&(TIMEDIF<.5):.5,1:TIMEDIF)
+ ..S TIME=$TR($J(TIMEDIF,4,0)," ")
+ ..S:TIME<0 TIME="###"
+ ..S:TIME ECSTIME=TIME
+ .S ECODE0=ECODE0_U_TIME K TIME
+ ; -Recovery Room Time
+ S ECRR=""
+ I $D(^SRF(ECD0,1.1)) D
+ .S A1=$P(^(1.1),U,8),A2=$P(^(1.1),U,7),TIME="##" D:(A1&A2) TIME
+ .S ECRR=TIME K TIME
+ I ECNL]"" S $P(ECODE0,U,5)=ECNT
+ ;
+ ; -OR Clean Time in 15 min increments DBIA #103
+ S ECXORCT=($$FMDIFF^XLFDT($P($G(DATA2),U,14),$P($G(DATA2),U,13),2)/60)/15
+ ; -If no OR clean time recorded set it to 2
+ I ECXORCT'>0 S ECXORCT=2
+ ;
+ ; -PT in hold area time in 15 min increments DBIA #103
+ I $P($G(DATA2),U,10),$P($G(DATA2),U,15) D
+ .S ECXPTHA=($$FMDIFF^XLFDT($P($G(DATA2),U,10),$P($G(DATA2),U,15),2)/60)/15
+ .S CON=$P($G(^SRF(ECD0,"CON")),U)
+ .I CON S ECXPTHA=ECXPTHA/2
+ .S ECXPTHA=$TR($J(ECXPTHA,3,0)," ")
+ ; -If hold time is =<0 set it to ""
+ S:$G(ECXPTHA)'>0 ECXPTHA=""
+ ;
+ ;- Observation Patient Indicator (yes/no)
+ S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECNL)
+ ;
+ ;- set national patient record flag if exist
+ D NPRF^ECXUTL5
+ ;
+ ;- If no encounter number don't file record
+ S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXSTOP,ECSS) Q:ECXENC=""
+ ;
+ D FILE
+ ;get secondary procedures
+ ;ecode0=s^cpt code
+ S ECXJ=0
+ ;F  S ECXJ=$O(^SRF(ECD0,13,ECXJ)) Q:'ECXJ  I $D(^(ECXJ,0)),$D(^(2)),$P(^(2),U)]"" D
+ F  S ECXJ=$O(^SRO(136,ECD0,3,ECXJ)) Q:'ECXJ  I $D(^(ECXJ,0)),$D(^(0)),$P(^(0),"^")]"" D
+ .;S ECPT=$P(^SRF(ECD0,13,ECXJ,2),U),ECXCMOD=""
+ . S ECPT=$P(^SRO(136,ECD0,3,ECXJ,0),"^"),ECXCMOD=""
+ .K ARR,ERR
+ .D FIELD^DID(130.16,4,,"LABEL","ARR","ERR") I $D(ARR("LABEL")) D
+ ..K ARR,ERR
+ ..D FIELD^DID(130.16,4,,"GLOBAL SUBSCRIPT LOCATION","ARR","ERR")
+ ..Q:$D(ERR("DIERR"))
+ ..S SUB=$P(ARR("GLOBAL SUBSCRIPT LOCATION"),";"),MOD=0
+ ..F  S MOD=$O(^SRF(ECD0,13,ECXJ,SUB,MOD)) Q:MOD'>0  S ECXCMOD=ECXCMOD_$P(^(MOD,0),U)_";"
+ .S ECXCPT=$$CPT^ECXUTL3(ECPT,ECXCMOD)
+ .S ECODE0="S"_U   ;_ECPT
+ .D FILE
+ ;get prostheses
+ ;ecode0=i^^^^^^prosthesis^old qty field (null)
+ S ECXJ=0
+ F  S ECXJ=$O(^SRF(ECD0,1,ECXJ)) Q:'ECXJ  I $D(^(ECXJ,0)) D
+ .S ECXP=+^SRF(ECD0,1,ECXJ,0),ECXQ=$P($G(^(1)),U,2) S:'ECXQ ECXQ=1
+ .S ECODE0="I"_U_U_U_U_U_U_ECXP_U_U
+ .D FILE
+ Q
+ ;
+FILE ;file record
+ ;node0
+ ;division^dfn^ssn^name^in/out (ECXA)^day^case #^
+ ;surg specialty^or room #^
+ ;surgeon^attending^anesthesia supervisor^anesthesia technique^
+ ;primary/secondary/prostheses^cpt^^pt time^op time^anes time^
+ ;prostheses^qty^^
+ ;movement number^treating specialty^cancel/abort (ECCAN)^time^or type^
+ ;attending's service^non-or dss id^recovery room time^^
+ ;primary care team^primary care provider^admission date
+ ;node1
+ ;mpi^dss dept ECXDSSD^surgeon npi^attending npi^anes supervisor npi^
+ ;pc provider npi^pc prov person class^
+ ;assoc pc provider^assoc pc prov person class^assoc pc prov npi^
+ ;cpt&modifiers ECXCPT^dom ECXDOM^enrollment category ECXCAT^
+ ;enrollment status ECXSTAT^enrollment priority ECXPRIOR^
+ ;period of service ECXPOS^purple heart indicator ECXPHI^
+ ;observ pat ind ECXOBS^encounter num ECXENC^ao loc ECXAOL^
+ ;production division ECXPDIV^head & neck canc ind ECXHNCI^
+ ;ethnicity ECXETH^race1 ECXRC1^new quantity ECXQ^
+ ;^user enrollee ECXUESTA^patient type ECXPTYPE^combat vet elig
+ ;ECXCVE^combat vet elig end date ECXCVEDT^enc cv eligible ECXCVENC
+ ;or clean time ECXORCT^time pt in hold area ECXPTHA^national patient
+ ;record flag ECXNPRFI^princ anesthetist ECXPA^surgeon per class ECSRPC
+ ;node2
+ ;atten surgeon per class ECATPC^anesthesia super person class ECSAPC^
+ ;princ anesthetist PC ECXPAPC^emergency response indicator(FEMA) ECXERI^
+ ;agent orange indic ECXAO^head/neck cancer ECXHNC
+ ;
+ N DA,DIK,STR
+ S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1
+ S ECODE=EC7_U_EC23_U_ECXDIV_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U
+ S ECODE=ECODE_$$ECXDATE^ECXUTL(ECXDATE,ECXYM)_U_ECD0_U_ECSS_U_ECO_U
+ S ECODE=ECODE_ECSR_U_ECAT_U_ECSA_U_ECANE_U_ECODE0_U
+ S STR=ECXMN_U_ECXTS_U_$S(ECCAN'="":ECCAN,1:"")_U_ECXTM_U_ECORTY_U
+ S STR=STR_ECATSV_U_ECNL_U_ECRR_U_U_ECPTTM_U_ECPTPR_U_ECXADD_U
+ S $P(ECODE,U,26,38)=STR
+ S ECODE1=ECXMPI_U_ECXDSSD_U_ECSRNPI_U_ECATNPI_U_ECSANPI_U_ECPTNPI_U
+ S ECODE1=ECODE1_ECCLAS_U_ECASPR_U_ECCLAS2_U_ECASNPI_U_ECXCPT_U_ECXDOM_U
+ S ECODE1=ECODE1_ECXCAT_U_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXPOS_U_ECXPHI_U
+ S ECODE1=ECODE1_ECXOBS_U_ECXENC_U_ECXAOL_U_ECXPDIV_U_ECXHNCI_U
+ S ECODE1=ECODE1_ECXETH_U_ECXRC1_U_ECXQ_U
+ I ECXLOGIC>2004 S ECODE1=ECODE1_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXORCT_U_ECXPTHA_U_ECXNPRFI
+ I ECXLOGIC>2005 S ECODE1=ECODE1_U_ECXPA_U_ECSRPC_U,ECODE2=ECATPC_U_ECSAPC_U_ECXPAPC
+ I ECXLOGIC>2006 S ECODE2=ECODE2_U_ECXERI_U_ECXAO_U_ECXHNC
+ S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,^ECX(ECFILE,EC7,2)=ECODE2,ECRN=ECRN+1
+ S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA
+ I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1
+ ;
+TIME ; given date/time get increment
+ ;A1=later, A2=earlier, TIME=difference
+ N CON,TIMEDIF
+ S CON=$P($G(^SRF(ECD0,"CON")),U)
+ ;
+ ;-Get time diff (in secs) & set to .5 if < 7.5 minutes (rounds to 1)
+ S TIMEDIF=$$FMDIFF^XLFDT(A1,A2,2)/900
+ S TIMEDIF=$S(TIMEDIF>0&(TIMEDIF<.5):.5,1:TIMEDIF)
+ I 'CON D
+ .S TIME=$J($TR($J(TIMEDIF,4,0)," "),2,1)
+ .S:TIME>"99.0" TIME="99.0"
+ I CON D
+ .S TIME=$J(($TR($J(TIMEDIF,4,0)," ")/2),2,1)
+ .S:TIME>"99.5" TIME="99.5"
+ S:TIME<0 TIME="###"
+ Q
+ ;
+SETUP ;Set required input for ECXTRAC
+ S ECHEAD="SUR"
+ D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
+ Q
+ ;
+QUE ; entry point for the background requeuing handled by ECXTAUTO
+ D SETUP,QUE^ECXTAUTO,^ECXKILL Q

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXTRAC.m

@@ -1 @@
-ECXTRAC ;ALB/GTS,JAP,BIR/DMA,CML-Package Extracts for DSS ; 7/29/07 12:51pm
-        ;;3.0;DSS EXTRACTS;**9,8,14,24,30,33,49,84,105**;Dec 22, 1997;Build 70
-        ;Date range, queuing and message sending for package extracts
-        ;Input
-        ;  ECPACK   printed name of package (e.g. Lab, Prescriptions)
-        ;  ECNODE   in file 728 where last date is stored
-        ;  ECPIECE  piece of node where last date is stored
-        ;  ECRTN    in the form of START^ROUTINE
-        ;  ECGRP    name of local mail group to receive summary message
-        ;           (MUST BE 1 TO 5 UPPER CASE ALPHA - NO SPACES)
-        ;  ECFILE   file number of the local editing file
-        ;  ECXLOGIC Fiscal year extract logic to use (optional)
-        ;  ECXDATES StartDate^EndDate^DoNotUpdate728 (optional)
-        ;Generates
-        ;  EC23=2nd and 3rd piece of zero node in local editing file
-        ;      =YYMM of end date^pointer to 727
-        ;  ECXLOGIC=Fiscal year extract logic to use
-        ;
-EN      ;entry point
-        N OUT,CHKFLG
-        I '$D(ECNODE) S ECNODE=7
-        I '$D(ECHEAD) S ECHEAD=" "
-        I $P($G(^ECX(728,1,ECNODE+.1)),U,ECPIECE)]"" D  Q
-        .W !!,$C(7),ECPACK," extract is already scheduled to run",!!
-        .D PAUSE
-        W @IOF,!,"Extract ",ECPACK," Information for DSS",!!
-        S:'$D(ECINST) ECINST=+$P(^ECX(728,1,0),U)
-        S ECXINST=ECINST
-        K ECXDIC S DA=ECINST,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99"
-        D EN^DIQ1 S ECINST=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC
-        ;* get last date for all extracts except prosthetics
-        I ECGRP'="PRO" D
-        .S ECLDT=$S($D(^ECX(728,1,ECNODE)):$P(^(ECNODE),U,ECPIECE),1:2610624)
-        .S:ECLDT="" ECLDT=2610624
-        ;* get last date for prosthetics
-        I ECGRP="PRO" D
-        .N ECXDA1
-        .S ECXDA1=$O(^ECX(728,0))
-        .I $D(^ECX(728,ECXDA1,1,ECXINST,0)) D
-        ..S ECLDT=$P(^ECX(728,ECXDA1,1,ECXINST,0),U,2)
-        .I '$D(^ECX(728,ECXDA1,1,ECXINST,0)) D
-        ..S DA(1)=ECXDA1
-        ..S DIC(0)="L" K ECXDD
-        ..D FIELD^DID(728,59,,"SPECIFIER","ECXDD")
-        ..S DIC("P")=ECXDD("SPECIFIER") K ECXDD
-        ..S DIC="^ECX(728,"_DA(1)_",1,",X=ECXINST,DINUM=X
-        ..K DD,DO D FILE^DICN
-        ..K DIC,X,DINUM,Y,DA
-        ..S ECLDT=2610624
-        S X=$G(ECXDATES) S ECSD=$P(X,"^",1),ECED=$P(X,"^",2)
-        S OUT=0
-        I (ECSD="")!(ECED="") F  S (ECED,ECSD)="" D  Q:OUT
-        .K %DT S %DT="AEX",%DT("A")="Starting with Date: " D ^%DT
-        .I Y<0 S OUT=1 Q
-        .S ECSD=Y
-        .K %DT S %DT="AEX",%DT("A")="Ending with Date: " D ^%DT
-        .I Y<0 S OUT=1 Q
-        .I Y<ECSD D  Q
-        ..W !!,"The ending date cannot be earlier than the starting date."
-        ..W !,"Please try again.",!!
-        .I $E(Y,1,5)'=$E(ECSD,1,5) D  Q
-        ..W !!,"Beginning and ending dates must be in the same month and year."
-        ..W !,"Please try again.",!!
-        .S ECED=Y
-        .I ECLDT'<ECSD D  Q
-        ..W !!,"The ",ECPACK," information has already been extracted through ",$$FMTE^XLFDT(ECLDT),"."
-        ..W !,"Please enter a new date range.",!!
-        .S OUT=1
-        I ECED]"",ECSD]"" D QUE
-        Q
-        ;
-QUE     ;queue extract
-        N CHKFLG
-        ;if extract is ivp (i.e., file=727.819) and data in the intermediate file use new format
-        I ECFILE=727.819 D  Q:CHKFLG
-        .S CHKFLG=0
-        .S X="PSIVSTAT" X ^%ZOSF("TEST") I '$T Q
-        .I '$D(^ECX(728.113,"A")) S CHKFLG=1 D NOIVP Q
-        .S DATE=$O(^ECX(728.113,"A",ECED+1),-1) I DATE<ECSD S CHKFLG=1 D NOIVP Q
-        .D CHK^ECXDIVIV Q:CHKFLG
-        .D CHK2
-        .S ECRTN="START^ECXPIVDN",ECVER=7
-        I '$D(ECNODE) S ECNODE=7
-        I '$D(ECHEAD) S ECHEAD=""
-        S ECSDN=$$FMTE^XLFDT(ECSD),ECEDN=$$FMTE^XLFDT(ECED),ECSD1=ECSD-.1
-        K ZTSAVE
-        F X="ECINST","ECED","ECSD","ECSD1","ECEDN","ECSDN" S ZTSAVE(X)=""
-        F X="ECPACK","ECPIECE","ECRTN","ECGRP","ECNODE" S ZTSAVE(X)=""
-        F X="ECFILE","ECHEAD","ECVER","ECINST","ECXINST" S ZTSAVE(X)=""
-        F X="ECXLOGIC","ECXDATES" S ZTSAVE(X)=""
-        S ZTDESC=ECPACK_" EXTRACT: "_ECSDN_" TO "_ECEDN,ZTRTN="START^ECXTRAC",ZTIO=""
-        D ^%ZTLOAD
-        I $D(ZTSK) D
-        .S $P(^ECX(728,1,ECNODE+.1),U,ECPIECE)="R"
-        .W !,"Request queued as Task #",ZTSK,".",!
-        .D PAUSE
-        Q
-        ;
-NOIVP   ;cannot generate ivp message
-        W !!,?5,"There does not appear to be any data in the IV EXTRACT DATA"
-        W !,?5,"file (#728.113) for the selected date range."
-        W !!,?5,"The IVP extract cannot be generated."
-        D PAUSE
-        Q
-        ;
-START   ; entry when queued
-        S QFLG=0
-        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)
-        S ^ECX(727,EC,0)=EC_U_DT_U_ECPACK_U_ECSD_U_$E(ECED,1,7)_U_U_DUZ
-        S ^ECX(727,EC,"HEAD")=ECHEAD
-        S:ECFILE=727.816 ECFILE=727.827 S ^ECX(727,EC,"FILE")=ECFILE
-        S ^ECX(727,EC,"GRP")=ECGRP
-        I $G(ECXLOGIC)="" S ECXLOGIC=$$FISCAL^ECXUTL1(ECSD)
-        S ^ECX(727,EC,"VER")=$G(ECVER)_"^"_ECXLOGIC
-        S ^ECX(727,EC,"DIV")=ECXINST
-        S DA=EC,DIK="^ECX(727," D IX^DIK K DIK,DA
-        S ECRN=0,ECXYM=$$ECXYM^ECXUTL(ECED),EC23=ECXYM_U_EC
-        S ECXSTART=$P($$HTE^XLFDT($H),":",1,2),ECXNOW=$H
-        ;do specific extract
-        D @ECRTN
-        ;if task gets stop request, set ztstop and quit
-        I QFLG D  Q
-        .S $P(^ECX(728,1,ECNODE+.1),U,ECPIECE)="",ZTSTOP=1
-        .D QKILL
-        .D QMSG
-        .D ^ECXKILL
-        ;Set last date for extract
-        I '$P($G(ECXDATES),"^",3) D
-        .;* set last date for all extracts except prosthetics
-        .I ECGRP'="PRO" S $P(^ECX(728,1,ECNODE),U,ECPIECE)=$P(ECED,".") Q
-        .;* set last date for prosthetics
-        .N ECXDA1
-        .S ECXDA1=$O(^ECX(728,0))
-        .S $P(^ECX(728,ECXDA1,1,ECXINST,0),U,2)=$P(ECED,".")
-        S TIME=$P($$HTE^XLFDT($H),":",1,2)
-        S $P(^ECX(727,$P(EC23,U,2),0),U,6)=ECRN
-        ;set piece 3 and 4 of the zero node
-        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
-        D MSG
-        S $P(^ECX(728,1,ECNODE+.1),U,ECPIECE)=""
-        I $D(ZTQUEUED) S ZTREQ="@"
-        Q
-        ;
-MSG     ; send message to mail group 'DSS-ECGRP'
-        S XMSUB=ECINST_" - "_ECPACK_" EXTRACT FOR DSS",XMDUZ="DSS SYSTEM"
-        K XMY S XMY("G.DSS-"_ECGRP_"@"_^XMB("NETNAME"))=""
-        S ECMSG(1,0)="The DSS-"_ECPACK_" extract (#"_$P(EC23,U,2)_") for "_ECSDN
-        S ECMSG(2,0)="through "_ECEDN_" was begun on "_$P(ECXSTART,"@")_" at "_$P(ECXSTART,"@",2)
-        S ECMSG(3,0)="and completed on "_$P(TIME,"@")_" at "_$P(TIME,"@",2)_"."
-        S ECMSG(4,0)=" "
-        S ECMSG(5,0)="A total of "_ECRN_" records were written."
-        S ECMSG(6,0)=" "
-        S ECMSG(7,0)="Extract time was [HH:MM:SS] "_$$HDIFF^XLFDT($H,ECXNOW,3)
-        S ECMSG(8,0)=" "
-        S X=$E(ECXLOGIC,5) S X=$S((X="")!(X=" "):"",1:"revision "_X_" of ")
-        S ECMSG(9,0)="The data was extracted using "_X_"fiscal year "_$E(ECXLOGIC,1,4)_" logic."
-        S ECMSG(10,0)=" "
-        S XMTEXT="ECMSG("
-        D ^XMD
-        Q
-        ;
-QMSG    ; send abort message to mail group 'DSS-ECGRP'
-        S XMSUB=ECINST_" - "_ECPACK_" EXTRACT FOR DSS",XMDUZ="DSS SYSTEM"
-        K XMY S XMY("G.DSS-"_ECGRP_"@"_^XMB("NETNAME"))=""
-        S ECMSG(1,0)="The DSS-"_ECPACK_" extract (#"_$P(EC23,U,2)_") for "_ECSDN
-        S ECMSG(2,0)="through "_ECEDN_" was begun on "_$P(ECXSTART,"@")_" at "_$P(ECXSTART,"@",2)_"."
-        S ECMSG(3,0)=" "
-        S ECMSG(4,0)="A user stop request was received by Taskmanager which caused processing"
-        S ECMSG(5,0)="to terminate before completion.  Any records which may have been created"
-        S ECMSG(6,0)="in file #"_ECFILE_" for this extract have been deleted."
-        S ECMSG(7,0)=" "
-        S XMTEXT="ECMSG("
-        D ^XMD
-        Q
-        ;
-QKILL   ;delete records created for any extract stopped at user request
-        N ECX,FILE,IEN,DA,DIK
-        S FILE="^ECX("_ECFILE_","
-        S ECX=$P(EC23,U,2)
-        F  S IEN=$O(^ECX(ECFILE,999999999),-1) Q:($P(^ECX(ECFILE,IEN,0),U,3)'=ECX)  D
-        .S DIK=FILE,DA=IEN D ^DIK
-        Q
-        ;
-CHK2    ;iv extract check - all active iv rooms to have a division
-        S EC=0
-        D ALL^PSJ59P5(,"??","ECXIV")
-        F  S EC=$O(^TMP($J,"ECXIV",EC)) Q:'EC  I '^(EC,19) D  I CHKFLG D EXIT Q
-        .S CHKFLG=$S($G(^TMP($J,"ECXIV",EC,19)):1,$G(^(19))>DT:1,1:0)
-        .I CHKFLG D
-        ..W !!,"All active IV Rooms in the IV Room file (#59.5) must have a ""DIVISION""",!,"assigned to run this extract!"
-        ..W !!,"This information can be entered using the DSS Extract Manager's Maintenance ",!,"option ""Enter/Edit IV Room Division""."
-        ..D PAUSE
-EXIT    K ^TMP($J,"ECXIV")
-        Q
-        ;
-PAUSE   ;pause screen
-        N DIR,X,Y
-        S OUT=0
-        I $E(IOST)="C" D
-        .S SS=22-$Y F JJ=1:1:SS W !
-        .S DIR(0)="E" W ! D ^DIR K DIR
-        I 'Y S OUT=1
-        W !!
-        Q
+ECXTRAC ;ALB/GTS,JAP,BIR/DMA,CML-Package Extracts for DSS ; 5/9/05 10:39am
+ ;;3.0;DSS EXTRACTS;**9,8,14,24,30,33,49,84**;Dec 22, 1997
+ ;Date range, queuing and message sending for package extracts
+ ;Input
+ ;  ECPACK   printed name of package (e.g. Lab, Prescriptions)
+ ;  ECNODE   in file 728 where last date is stored
+ ;  ECPIECE  piece of node where last date is stored
+ ;  ECRTN    in the form of START^ROUTINE
+ ;  ECGRP    name of local mail group to receive summary message
+ ;           (MUST BE 1 TO 5 UPPER CASE ALPHA - NO SPACES)
+ ;  ECFILE   file number of the local editing file
+ ;  ECXLOGIC Fiscal year extract logic to use (optional)
+ ;  ECXDATES StartDate^EndDate^DoNotUpdate728 (optional)
+ ;Generates
+ ;  EC23=2nd and 3rd piece of zero node in local editing file
+ ;      =YYMM of end date^pointer to 727
+ ;  ECXLOGIC=Fiscal year extract logic to use
+ ;
+EN ;entry point
+ N OUT,CHKFLG
+ I '$D(ECNODE) S ECNODE=7
+ I '$D(ECHEAD) S ECHEAD=" "
+ I $P($G(^ECX(728,1,ECNODE+.1)),U,ECPIECE)]"" D  Q
+ .W !!,$C(7),ECPACK," extract is already scheduled to run",!!
+ .D PAUSE
+ W @IOF,!,"Extract ",ECPACK," Information for DSS",!!
+ S:'$D(ECINST) ECINST=+$P(^ECX(728,1,0),U)
+ S ECXINST=ECINST
+ K ECXDIC S DA=ECINST,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99"
+ D EN^DIQ1 S ECINST=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC
+ ;* get last date for all extracts except prosthetics
+ I ECGRP'="PRO" D
+ .S ECLDT=$S($D(^ECX(728,1,ECNODE)):$P(^(ECNODE),U,ECPIECE),1:2610624)
+ .S:ECLDT="" ECLDT=2610624
+ ;* get last date for prosthetics
+ I ECGRP="PRO" D
+ .N ECXDA1
+ .S ECXDA1=$O(^ECX(728,0))
+ .I $D(^ECX(728,ECXDA1,1,ECXINST,0)) D
+ ..S ECLDT=$P(^ECX(728,ECXDA1,1,ECXINST,0),U,2)
+ .I '$D(^ECX(728,ECXDA1,1,ECXINST,0)) D
+ ..S DA(1)=ECXDA1
+ ..S DIC(0)="L" K ECXDD
+ ..D FIELD^DID(728,59,,"SPECIFIER","ECXDD")
+ ..S DIC("P")=ECXDD("SPECIFIER") K ECXDD
+ ..S DIC="^ECX(728,"_DA(1)_",1,",X=ECXINST,DINUM=X
+ ..K DD,DO D FILE^DICN
+ ..K DIC,X,DINUM,Y,DA
+ ..S ECLDT=2610624
+ S X=$G(ECXDATES) S ECSD=$P(X,"^",1),ECED=$P(X,"^",2)
+ S OUT=0
+ I (ECSD="")!(ECED="") F  S (ECED,ECSD)="" D  Q:OUT
+ .K %DT S %DT="AEX",%DT("A")="Starting with Date: " D ^%DT
+ .I Y<0 S OUT=1 Q
+ .S ECSD=Y
+ .K %DT S %DT="AEX",%DT("A")="Ending with Date: " D ^%DT
+ .I Y<0 S OUT=1 Q
+ .I Y<ECSD D  Q
+ ..W !!,"The ending date cannot be earlier than the starting date."
+ ..W !,"Please try again.",!!
+ .I $E(Y,1,5)'=$E(ECSD,1,5) D  Q
+ ..W !!,"Beginning and ending dates must be in the same month and year."
+ ..W !,"Please try again.",!!
+ .S ECED=Y
+ .I ECLDT'<ECSD D  Q
+ ..W !!,"The ",ECPACK," information has already been extracted through ",$$FMTE^XLFDT(ECLDT),"."
+ ..W !,"Please enter a new date range.",!!
+ .S OUT=1
+ I ECED]"",ECSD]"" D QUE
+ Q
+ ;
+QUE ;queue extract
+ N CHKFLG
+ ;if extract is ivp (i.e., file=727.819) and data in the intermediate file use new format
+ I ECFILE=727.819 D  Q:CHKFLG
+ .S CHKFLG=0
+ .S X="PSIVSTAT" X ^%ZOSF("TEST") I '$T Q
+ .I '$D(^ECX(728.113,"A")) S CHKFLG=1 D NOIVP Q
+ .S DATE=$O(^ECX(728.113,"A",ECED+1),-1) I DATE<ECSD S CHKFLG=1 D NOIVP Q
+ .D CHK^ECXDIVIV Q:CHKFLG
+ .D CHK2
+ .S ECRTN="START^ECXPIVDN",ECVER=7
+ I '$D(ECNODE) S ECNODE=7
+ I '$D(ECHEAD) S ECHEAD=""
+ S ECSDN=$$FMTE^XLFDT(ECSD),ECEDN=$$FMTE^XLFDT(ECED),ECSD1=ECSD-.1
+ K ZTSAVE
+ F X="ECINST","ECED","ECSD","ECSD1","ECEDN","ECSDN" S ZTSAVE(X)=""
+ F X="ECPACK","ECPIECE","ECRTN","ECGRP","ECNODE" S ZTSAVE(X)=""
+ F X="ECFILE","ECHEAD","ECVER","ECINST","ECXINST" S ZTSAVE(X)=""
+ F X="ECXLOGIC","ECXDATES" S ZTSAVE(X)=""
+ S ZTDESC=ECPACK_" EXTRACT: "_ECSDN_" TO "_ECEDN,ZTRTN="START^ECXTRAC",ZTIO=""
+ D ^%ZTLOAD
+ I $D(ZTSK) D
+ .S $P(^ECX(728,1,ECNODE+.1),U,ECPIECE)="R"
+ .W !,"Request queued as Task #",ZTSK,".",!
+ .D PAUSE
+ Q
+ ;
+NOIVP ;cannot generate ivp message
+ W !!,?5,"There does not appear to be any data in the IV EXTRACT DATA"
+ W !,?5,"file (#728.113) for the selected date range."
+ W !!,?5,"The IVP extract cannot be generated."
+ D PAUSE
+ Q
+ ;
+START ; entry when queued
+ S QFLG=0
+ 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)
+ S ^ECX(727,EC,0)=EC_U_DT_U_ECPACK_U_ECSD_U_$E(ECED,1,7)_U_U_DUZ
+ S ^ECX(727,EC,"HEAD")=ECHEAD
+ S:ECFILE=727.816 ECFILE=727.827 S ^ECX(727,EC,"FILE")=ECFILE
+ S ^ECX(727,EC,"GRP")=ECGRP
+ I $G(ECXLOGIC)="" S ECXLOGIC=$$FISCAL^ECXUTL1(ECSD)
+ S ^ECX(727,EC,"VER")=$G(ECVER)_"^"_ECXLOGIC
+ S ^ECX(727,EC,"DIV")=ECXINST
+ S DA=EC,DIK="^ECX(727," D IX^DIK K DIK,DA
+ S ECRN=0,ECXYM=$$ECXYM^ECXUTL(ECED),EC23=ECXYM_U_EC
+ S ECXSTART=$P($$HTE^XLFDT($H),":",1,2),ECXNOW=$H
+ ;do specific extract
+ D @ECRTN
+ ;if task gets stop request, set ztstop and quit
+ I QFLG D  Q
+ .S $P(^ECX(728,1,ECNODE+.1),U,ECPIECE)="",ZTSTOP=1
+ .D QKILL
+ .D QMSG
+ .D ^ECXKILL
+ ;Set last date for extract
+ I '$P($G(ECXDATES),"^",3) D
+ .;* set last date for all extracts except prosthetics
+ .I ECGRP'="PRO" S $P(^ECX(728,1,ECNODE),U,ECPIECE)=$P(ECED,".") Q
+ .;* set last date for prosthetics
+ .N ECXDA1
+ .S ECXDA1=$O(^ECX(728,0))
+ .S $P(^ECX(728,ECXDA1,1,ECXINST,0),U,2)=$P(ECED,".")
+ S TIME=$P($$HTE^XLFDT($H),":",1,2)
+ S $P(^ECX(727,$P(EC23,U,2),0),U,6)=ECRN
+ ;set piece 3 and 4 of the zero node
+ 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
+ D MSG
+ S $P(^ECX(728,1,ECNODE+.1),U,ECPIECE)=""
+ I $D(ZTQUEUED) S ZTREQ="@"
+ Q
+ ;
+MSG ; send message to mail group 'DSS-ECGRP'
+ S XMSUB=ECINST_" - "_ECPACK_" EXTRACT FOR DSS",XMDUZ="DSS SYSTEM"
+ K XMY S XMY("G.DSS-"_ECGRP_"@"_^XMB("NETNAME"))=""
+ S ECMSG(1,0)="The DSS-"_ECPACK_" extract (#"_$P(EC23,U,2)_") for "_ECSDN
+ S ECMSG(2,0)="through "_ECEDN_" was begun on "_$P(ECXSTART,"@")_" at "_$P(ECXSTART,"@",2)
+ S ECMSG(3,0)="and completed on "_$P(TIME,"@")_" at "_$P(TIME,"@",2)_"."
+ S ECMSG(4,0)=" "
+ S ECMSG(5,0)="A total of "_ECRN_" records were written."
+ S ECMSG(6,0)=" "
+ S ECMSG(7,0)="Extract time was [HH:MM:SS] "_$$HDIFF^XLFDT($H,ECXNOW,3)
+ S ECMSG(8,0)=" "
+ S X=$E(ECXLOGIC,5) S X=$S((X="")!(X=" "):"",1:"revision "_X_" of ")
+ S ECMSG(9,0)="The data was extracted using "_X_"fiscal year "_$E(ECXLOGIC,1,4)_" logic."
+ S ECMSG(10,0)=" "
+ S XMTEXT="ECMSG("
+ D ^XMD
+ Q
+ ;
+QMSG ; send abort message to mail group 'DSS-ECGRP'
+ S XMSUB=ECINST_" - "_ECPACK_" EXTRACT FOR DSS",XMDUZ="DSS SYSTEM"
+ K XMY S XMY("G.DSS-"_ECGRP_"@"_^XMB("NETNAME"))=""
+ S ECMSG(1,0)="The DSS-"_ECPACK_" extract (#"_$P(EC23,U,2)_") for "_ECSDN
+ S ECMSG(2,0)="through "_ECEDN_" was begun on "_$P(ECXSTART,"@")_" at "_$P(ECXSTART,"@",2)_"."
+ S ECMSG(3,0)=" "
+ S ECMSG(4,0)="A user stop request was received by Taskmanager which caused processing"
+ S ECMSG(5,0)="to terminate before completion.  Any records which may have been created"
+ S ECMSG(6,0)="in file #"_ECFILE_" for this extract have been deleted."
+ S ECMSG(7,0)=" "
+ S XMTEXT="ECMSG("
+ D ^XMD
+ Q
+ ;
+QKILL ;delete records created for any extract stopped at user request
+ N ECX,FILE,IEN,DA,DIK
+ S FILE="^ECX("_ECFILE_","
+ S ECX=$P(EC23,U,2)
+ F  S IEN=$O(^ECX(ECFILE,999999999),-1) Q:($P(^ECX(ECFILE,IEN,0),U,3)'=ECX)  D
+ .S DIK=FILE,DA=IEN D ^DIK
+ Q
+ ;
+CHK2 ;iv extract check - all active iv rooms to have a division
+ S EC=0
+ F  S EC=$O(^PS(59.5,EC)) Q:'EC  I '$P(^PS(59.5,EC,0),U,4) D  Q:CHKFLG
+ .S CHKFLG=$S('$G(^PS(59.5,EC,"I")):1,$G(^PS(59.5,EC,"I"))>DT:1,1:0)
+ .I CHKFLG D
+ ..W !!,"All active IV Rooms in the IV Room file (#59.5) must have a ""DIVISION""",!,"assigned to run this extract!"
+ ..W !!,"This information can be entered using the DSS Extract Manager's Maintenance ",!,"option ""Enter/Edit IV Room Division""."
+ ..D PAUSE
+ Q
+ ;
+PAUSE ;pause screen
+ N DIR,X,Y
+ S OUT=0
+ I $E(IOST)="C" D
+ .S SS=22-$Y F JJ=1:1:SS W !
+ .S DIR(0)="E" W ! D ^DIR K DIR
+ I 'Y S OUT=1
+ W !!
+ Q

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXTREX.m

@@ -1 @@
-ECXTREX ;BPFO/JRP - Queue DSS Fiscal Year Specific Extract;8-AUG-2003 ; 6/11/07 12:46pm
-        ;;3.0;DSS EXTRACTS;**49,71,84,92,105**;Dec 22, 1997;Build 70
-        ;
-EN      ;Main entry point
-        W @IOF
-        N DIC,X,Y,DTOUT,DUOUT
-        W !,"****************************************************************"
-        W !,"*                                                              *"
-        W !,"* This option should be used with caution as it allows for the *"
-        W !,"* extraction of data using specified fiscal year logic.  This  *"
-        W !,"* gives the ability to extract fiscal year 200x data using     *"
-        W !,"* fiscal year 200(x+1) logic and vice versa.  Note that data   *"
-        W !,"* extracted via this method may or may not be transmittable to *"
-        W !,"* the DSS production queue at the Austin Automation Center.    *"
-        W !,"*                                                              *"
-        W !,"*--------------------------------------------------------------*"
-        W !,"*                                                              *"
-        W !,"* Note that this option does not update the last date used for *"
-        W !,"* the given extraction.  It also does not verify that the time *"
-        W !,"* frame selected is after the last date used for the extract.  *"
-        W !,"*                                                              *"
-        W !,"****************************************************************"
-        W !!
-        ;Pick extract to queue
-        S DIC="^ECX(727.1,"
-        S DIC(0)="AEQMZ"
-        S DIC("A")="Select DSS Extract to queue: "
-        S DIC("S")="I ('$P(^(0),U,12))&($P(^(0),U,8)'="""")&($G(^(7))'[""Inactive"")"
-        S DIC("W")="W ""("",$P(^(0),U,8),"")"""
-        D ^DIC
-        I ($D(DUOUT))!($D(DTOUT))!(Y<1) Q
-        N ECXRTN,ECXDA
-        S ECXDA=+Y
-        ;Get extract specific routine name
-        S ECXRTN=$G(^ECX(727.1,ECXDA,"ROU"))
-        I ECXRTN="" D  Q
-        .W !!,"Selected extract is not correctly defined in the EXTRACT"
-        .W !,"DEFINITIONS file (#727.1).  The ROUTINE field (#4) does not"
-        .W !,"have a value in it."
-        .W !
-        .D PAUSE
-        ;Get time frame for extract
-        N STRTDT,ENDDT,DIR,DIRUT,DIROUT,OUT,ECXDATES
-        S OUT=0 F  S (STRTDT,ENDDT)="" D  Q:OUT
-        .;Get start date (must be in past)
-        .S DIR(0)="DOA"
-        .S $P(DIR(0),"^",2)=":"_DT_":AEXP"
-        .S DIR("A")="Starting with Date: "
-        .D ^DIR
-        .I $D(DIROUT)!$D(DIRUT)!(Y="") S (STRTDT,ENDDT)="" S OUT=1 Q
-        .S STRTDT=Y
-        .K DIR
-        .;Get end date (must be in same month; must be in past)
-        .S DIR(0)="DOA"
-        .S X=$E(STRTDT,1,5)_"01"
-        .S X=$$FMADD^XLFDT(X,32)
-        .S X=$$FMADD^XLFDT(X,-($E(X,6,7)))
-        .I X>DT S X=DT
-        .S $P(DIR(0),"^",2)=STRTDT_":"_X_":AEXP"
-        .S DIR("A")="Ending with Date: "
-        .S DIR("B")=$$FMTE^XLFDT(X,"5D")
-        .D ^DIR
-        .I $D(DIROUT)!$D(DIRUT)!(Y="") S (STRTDT,ENDDT)=""  S OUT=1 Q
-        .S ENDDT=Y
-        .S OUT=1
-        Q:(STRTDT="")!(ENDDT="")
-        S ECXDATES=STRTDT_"^"_ENDDT_"^1"
-        ;Get extract logic to use
-        N ECXLOGIC
-        K DIR
-        S DIR("A")="Select fiscal year logic to use for extract"
-        S DIR(0)="SO^"
-        F X=2003,2004,2005,2006,2007,2008 D
-        .S Y=$E(X,5)
-        .S Y=$S((Y="")!(Y=" "):"",1:"Revision "_Y_" of ")
-        .S DIR(0)=DIR(0)_X_":"_Y_"Fiscal Year "_$E(X,1,4)_";"
-        D ^DIR
-        I $D(DIROUT)!$D(DIRUT) Q
-        S ECXLOGIC=Y
-        ;Queue extract
-        D @("BEG^"_ECXRTN)
-        Q
-PAUSE   ;pause screen
-        N DIR,X,Y,DTOUT,DUOUT,DIROUT,DIRUT
-        S DIR(0)="E"
-        W !!
-        D ^DIR
-        W !!
-        Q
+ECXTREX ;BPFO/JRP - Queue DSS Fiscal Year Specific Extract;8-AUG-2003 ; 11/2/06 9:02am
+ ;;3.0;DSS EXTRACTS;**49,71,84,92**;Dec 22, 1997;Build 30
+ ;
+EN ;Main entry point
+ W @IOF
+ N DIC,X,Y,DTOUT,DUOUT
+ W !,"****************************************************************"
+ W !,"*                                                              *"
+ W !,"* This option should be used with caution as it allows for the *"
+ W !,"* extraction of data using specified fiscal year logic.  This  *"
+ W !,"* gives the ability to extract fiscal year 200x data using     *"
+ W !,"* fiscal year 200(x+1) logic and vice versa.  Note that data   *"
+ W !,"* extracted via this method may or may not be transmittable to *"
+ W !,"* the DSS production queue at the Austin Automation Center.    *"
+ W !,"*                                                              *"
+ W !,"*--------------------------------------------------------------*"
+ W !,"*                                                              *"
+ W !,"* Note that this option does not update the last date used for *"
+ W !,"* the given extraction.  It also does not verify that the time *"
+ W !,"* frame selected is after the last date used for the extract.  *"
+ W !,"*                                                              *"
+ W !,"****************************************************************"
+ W !!
+ ;Pick extract to queue
+ S DIC="^ECX(727.1,"
+ S DIC(0)="AEQMZ"
+ S DIC("A")="Select DSS Extract to queue: "
+ S DIC("S")="I ('$P(^(0),U,12))&($P(^(0),U,8)'="""")&($G(^(7))'[""Inactive"")"
+ S DIC("W")="W ""("",$P(^(0),U,8),"")"""
+ D ^DIC
+ I ($D(DUOUT))!($D(DTOUT))!(Y<1) Q
+ N ECXRTN,ECXDA
+ S ECXDA=+Y
+ ;Get extract specific routine name
+ S ECXRTN=$G(^ECX(727.1,ECXDA,"ROU"))
+ I ECXRTN="" D  Q
+ .W !!,"Selected extract is not correctly defined in the EXTRACT"
+ .W !,"DEFINITIONS file (#727.1).  The ROUTINE field (#4) does not"
+ .W !,"have a value in it."
+ .W !
+ .D PAUSE
+ ;Get time frame for extract
+ N STRTDT,ENDDT,DIR,DIRUT,DIROUT,OUT,ECXDATES
+ S OUT=0 F  S (STRTDT,ENDDT)="" D  Q:OUT
+ .;Get start date (must be in past)
+ .S DIR(0)="DOA"
+ .S $P(DIR(0),"^",2)=":"_DT_":AEXP"
+ .S DIR("A")="Starting with Date: "
+ .D ^DIR
+ .I $D(DIROUT)!$D(DIRUT)!(Y="") S (STRTDT,ENDDT)="" S OUT=1 Q
+ .S STRTDT=Y
+ .K DIR
+ .;Get end date (must be in same month; must be in past)
+ .S DIR(0)="DOA"
+ .S X=$E(STRTDT,1,5)_"01"
+ .S X=$$FMADD^XLFDT(X,32)
+ .S X=$$FMADD^XLFDT(X,-($E(X,6,7)))
+ .I X>DT S X=DT
+ .S $P(DIR(0),"^",2)=STRTDT_":"_X_":AEXP"
+ .S DIR("A")="Ending with Date: "
+ .S DIR("B")=$$FMTE^XLFDT(X,"5D")
+ .D ^DIR
+ .I $D(DIROUT)!$D(DIRUT)!(Y="") S (STRTDT,ENDDT)=""  S OUT=1 Q
+ .S ENDDT=Y
+ .S OUT=1
+ Q:(STRTDT="")!(ENDDT="")
+ S ECXDATES=STRTDT_"^"_ENDDT_"^1"
+ ;Get extract logic to use
+ N ECXLOGIC
+ K DIR
+ S DIR("A")="Select fiscal year logic to use for extract"
+ S DIR(0)="SO^"
+ F X=2003,2004,2005,2006,2007 D
+ .S Y=$E(X,5)
+ .S Y=$S((Y="")!(Y=" "):"",1:"Revision "_Y_" of ")
+ .S DIR(0)=DIR(0)_X_":"_Y_"Fiscal Year "_$E(X,1,4)_";"
+ D ^DIR
+ I $D(DIROUT)!$D(DIRUT) Q
+ S ECXLOGIC=Y
+ ;Queue extract
+ D @("BEG^"_ECXRTN)
+ Q
+PAUSE ;pause screen
+ N DIR,X,Y,DTOUT,DUOUT,DIROUT,DIRUT
+ S DIR(0)="E"
+ W !!
+ D ^DIR
+ W !!
+ Q

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXTRT.m

@@ -1 @@
-ECXTRT  ;ALB/JAP,BIR/DMA,CML,PTD-Treating Specialty Change Extract ; 10/17/07 3:48pm
-        ;;3.0;DSS EXTRACTS;**1,8,17,24,33,35,39,46,49,84,107,105**;Dec 22, 1997;Build 70
-BEG     ;entry point from option
-        D SETUP I ECFILE="" Q
-        D ^ECXTRAC,^ECXKILL
-        Q
-        ;
-START   ; start package specific extract
-        N LOC,SPC,TRT,WRD
-        S QFLG=0
-        K ECXDD D FIELD^DID(405,.19,,"SPECIFIER","ECXDD")
-        S ECPRO=$E(+$P(ECXDD("SPECIFIER"),"P",2)) K ECXDD
-        K ^TMP($J,"ECXTMP") S TRT=0
-        F  S TRT=$O(^DIC(45.7,TRT)) Q:+TRT=0  S SPC=$P(^DIC(45.7,TRT,0),U,2),^TMP($J,"ECXTMP",TRT)=SPC
-        S ECED=ECED+.3,ECD=ECSD1
-        ;loop through type 6 movements to get treating specialty and provider changes
-        F  S ECD=$O(^DGPM("ATT6",ECD)),ECDA=0 Q:('ECD)!(ECD>ECED)!(QFLG)  F  S ECDA=$O(^DGPM("ATT6",ECD,ECDA)) Q:'ECDA  D  Q:QFLG
-        .I $D(^DGPM(ECDA,0)) S EC=^(0),ECXDFN=+$P(EC,U,3) D  Q:QFLG
-        ..S ECXMVD1=$P(EC,U),WRD=$P(EC,U,6)
-        ..;
-        ..;- Call sets ECXA (In/Out indicator)
-        ..Q:'$$PATDEM^ECXUTL2(ECXDFN,ECXMVD1,"1;",13)
-        ..S ECMT=$P(EC,U,18),ECXADM=$P(EC,U,14),ECXADT=$P($G(^DGPM(ECXADM,0)),U)
-        ..;skip the record if its the admission treat. spec. change for this episode of care
-        ..Q:ECXADM=$P(EC,U,24)
-        ..S (ECXLOS,ECXLOSA,ECXLOSP)="" S ECXDSSD=""
-        ..K LOC D SETLOC(ECXDFN,ECXADM,ECPRO,.LOC)
-        ..;get data for current (new) ts movement
-        ..S ECD1=9999999.9999999-ECXMVD1
-        ..D FINDLOC(ECD1,.LOC,.ECXSPCN,.ECXPRVN,.ECXATTN,.ECXMOVN,.ECXTRTN)
-        ..Q:ECXSPCN=""
-        ..S ECD2=$O(LOC(ECD1)) Q:ECD2=""
-        ..S ECXMVD2=9999999.9999999-ECD2
-        ..;get data for previous (losing) ts movement
-        ..D FINDLOC(ECD2,.LOC,.ECXSPCL,.ECXPRVL,.ECXATTL,.ECXMOVL,.ECXTRTL)
-        ..;if ts has changed, find los on losing ts
-        ..D:ECXTRTL'=ECXTRTN PREVTRT^ECXTRT1(.LOC,ECD1,ECD2,ECXTRTL,.ECXLOS)
-        ..;whether ts has changed or not, see if primary provider has changed
-        ..;don't bother if there's no data on current primary provider or no change in provider
-        ..D:(ECXPRVN'="")&(ECXPRVN'=ECXPRVL) PREVPRV^ECXTRT1(.LOC,ECD1,ECXPRVN,ECD2,.ECXPRVL,.ECXLOSP)
-        ..;whether ts has changed or not, see if attending physician has changed
-        ..;don't bother if there's no data on current attending physician or no change in attending
-        ..D:(ECXATTN'="")&(ECXATTN'=ECXATTL) PREVATT^ECXTRT1(.LOC,ECD1,ECXATTN,ECD2,.ECXATTL,.ECXLOSA)
-        ..S ECXDATE=$$ECXDATE^ECXUTL(ECXMVD1,ECXYM),ECXTIME=$$ECXTIME^ECXUTL(ECXMVD1)
-        ..S ECXADMDT=$$ECXDATE^ECXUTL(ECXADT,ECXYM),ECXADMTM=$$ECXTIME^ECXUTL(ECXADT),ECXDCDT=""
-        ..;- Production Division
-        ..S ECXPDIV=""
-        ..I ECXLOGIC>2003 S ECXPDIV=$S(WRD="":"",1:$$NPDIV(WRD))
-        ..;
-        ..;- Observation patient indicator (YES/NO)
-        ..S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS)
-        ..;
-        ..;- Chg outpat with movemnt/discharge to inpat (to comply w/existing business rule)
-        ..I ECXA="O"&(ECXOBS="NO")&(ECXMVD1) S ECXA="I"
-        ..;
-        ..;- Get providers person classes
-        .. S ECXATLPC=$$PRVCLASS^ECXUTL($E(ECXATTL,2,999),ECXADT)
-        .. S ECATLNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXATTL,2,999),ECXADT)
-        .. S:+ECATLNPI'>0 ECATLNPI="" S ECATLNPI=$P(ECATLNPI,U)
-        .. S ECXPRNPC=$$PRVCLASS^ECXUTL($E(ECXPRVN,2,999),ECXADT)
-        .. S ECPRVNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXPRVN,2,999),ECXADT)
-        .. S:+ECPRVNPI'>0 ECPRVNPI="" S ECPRVNPI=$P(ECPRVNPI,U)
-        .. S ECXATNPC=$$PRVCLASS^ECXUTL($E(ECXATTN,2,999),ECXADT)
-        .. S ECATTNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXATTN,2,999),ECXADT)
-        .. S:+ECATTNPI'>0 ECATTNPI="" S ECATTNPI=$P(ECATTNPI,U)
-        .. S ECXPRLPC=$$PRVCLASS^ECXUTL($E(ECXPRVL,2,999),ECXADT)
-        .. S ECPRLNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXPRVL,2,999),ECXADT)
-        .. S:+ECPRLNPI'>0 ECPRLNPI="" S ECPRLNPI=$P(ECPRLNPI,U)
-        ..;
-        ..;- If no encounter number, don't file record
-        ..S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADT,,ECXTS,ECXOBS,ECHEAD,,)
-        ..D:ECXENC'="" FILE^ECXTRT2
-        ;for nhcu episodes with intervening asih stays, the los calculated here is not accurate,
-        ;but it never has been; this is best solution within current extract framework;
-        ;at discharge the los calculated for nhcu episodes will be the los since admission w/o asih los subtracted;
-        ;
-        ;loop through discharges to get last treating specialty
-        S ECD=ECSD1
-        F  S ECD=$O(^DGPM("ATT3",ECD)),ECDA=0 Q:'ECD  Q:ECD>ECED  F  S ECDA=$O(^DGPM("ATT3",ECD,ECDA)) Q:'ECDA  D  Q:QFLG
-        .I $D(^DGPM(ECDA,0)) S EC=^(0),ECXDFN=+$P(EC,U,3) D  Q:QFLG
-        ..S ECXMVD1=$P(EC,U),WRD=$P(EC,U,6)
-        ..S (ECXDATE,ECXDCDT)=$$ECXDATE^ECXUTL(ECXMVD1,ECXYM),ECXTIME=$$ECXTIME^ECXUTL(ECXMVD1)
-        ..I ECXDCDT'>0 S ECXDCDT=""
-        ..S ECMT=$P(EC,U,18),ECXADM=$P(EC,U,14),ECXADT=$P($G(^DGPM(ECXADM,0)),U,1)
-        ..S (ECXTRTN,ECXSPCN,ECXPRVN,ECXATTN)="" S (ECXLOS,ECXLOSA,ECXLOSP)="" S ECXDSSD=""
-        ..K LOC D SETLOC(ECXDFN,ECXADM,ECPRO,.LOC)
-        ..S ECD1=9999999.9999999-ECXMVD1
-        ..;get ts change just before d/c
-        ..S ECD2=$O(LOC(ECD1)),ECXMVD2=9999999.9999999-ECD2
-        ..D FINDLOC(ECD2,.LOC,.ECXSPCL,.ECXPRVL,.ECXATTL,.ECXMOVL,.ECXTRTL)
-        ..;
-        ..;- Call sets ECXA (In/Out indicator) using date before discharge
-        ..Q:'$$PATDEM^ECXUTL2(ECXDFN,ECXMVD2,"1;",13)
-        ..S ECXADMDT=$$ECXDATE^ECXUTL(ECXADT,ECXYM),ECXADMTM=$$ECXTIME^ECXUTL(ECXADT)
-        ..;if closest ts change is admission ts, cant go back any further
-        ..S TRT=$O(LOC(ECD2,0)),REC=$O(LOC(ECD2,TRT,0))
-        ..I REC=ECXADM D
-        ...S X1=ECXMVD1,X2=ECXMVD2 D ^%DTC S ECXLOS=X
-        ...I ECXPRVL'="" S X1=ECXMVD1,X2=ECXMVD2 D ^%DTC S ECXLOSP=X
-        ...I ECXATTL'="" S X1=ECXMVD1,X2=ECXMVD2 D ^%DTC S ECXLOSA=X
-        ..;otherwise, need to find when change to last ts occurred
-        ..I REC'=ECXADM D
-        ...D PREVTRT^ECXTRT1(.LOC,ECD1,ECD2,ECXTRTL,.ECXLOS)
-        ...D PREVPRV^ECXTRT1(.LOC,ECD1,ECXPRVN,ECD2,.ECXPRVL,.ECXLOSP)
-        ...D PREVATT^ECXTRT1(.LOC,ECD1,ECXATTN,ECD2,.ECXATTL,.ECXLOSA)
-        ..S:ECXLOS>9999 ECXLOS=9999 S:ECXLOSA>9999 ECXLOSA=9999
-        ..S:ECXLOSP>9999 ECXLOSP=9999
-        ..;- Production Division
-        ..S ECXPDIV=""
-        ..I ECXLOGIC>2003 S ECXPDIV=$S(WRD="":"",1:$$NPDIV(WRD))
-        ..;
-        ..;- Observation patient indicator (YES/NO)
-        ..S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS)
-        ..;
-        ..;- Chg outpat with movemnt/discharge to inpat (to comply w/existing business rule)
-        ..I ECXA="O"&(ECXOBS="NO")&(ECXMVD1) S ECXA="I"
-        ..;
-        ..;- Get providers person classes
-        .. S ECXATLPC=$$PRVCLASS^ECXUTL($E(ECXATTL,2,999),ECXADT)
-        .. S ECATLNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXATTL,2,999),ECXADT)
-        .. S:+ECATLNPI'>0 ECATLNPI="" S ECATLNPI=$P(ECATLNPI,U)
-        .. S ECXPRNPC=$$PRVCLASS^ECXUTL($E(ECXPRVN,2,999),ECXADT)
-        .. S ECPRVNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXPRVN,2,999),ECXADT)
-        .. S:+ECPRVNPI'>0 ECPRVNPI="" S ECPRVNPI=$P(ECPRVNPI,U)
-        .. S ECXATNPC=$$PRVCLASS^ECXUTL($E(ECXATTN,2,999),ECXADT)
-        .. S ECATTNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXATTN,2,999),ECXADT)
-        .. S:+ECATTNPI'>0 ECATTNPI="" S ECATTNPI=$P(ECATTNPI,U)
-        .. S ECXPRLPC=$$PRVCLASS^ECXUTL($E(ECXPRVL,2,999),ECXADT)
-        .. S ECPRLNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXPRVL,2,999),ECXADT)
-        .. S:+ECPRLNPI'>0 ECPRLNPI="" S ECPRLNPI=$P(ECPRLNPI,U)
-        ..;
-        ..;- If no encounter number don't file record
-        ..S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADT,,ECXTS,ECXOBS,ECHEAD,,)
-        ..D:ECXENC'="" FILE^ECXTRT2
-        D KPATDEM^ECXUTL2
-        Q
-        ;
-NPDIV(WRD)      ;National Production Division
-        N DIV
-        S DIV=$$GET1^DIQ(42,WRD,.015,"I")
-        Q $S(DIV="":"",1:$$GETDIV^ECXDEPT(DIV))
-        ;
-SETLOC(ECXDFN,ECXADM,ECXPRO,ECXLOC)     ;setup the local array from the ATS index
-        ; output
-        ; ECXLOC = local array (passed by reference)
-        ;
-        N SUB3,SUB4,SUB5,SPC,PRV,ATT,MOV
-        S SUB3=0
-        F  S SUB3=$O(^DGPM("ATS",ECXDFN,ECXADM,SUB3)) Q:SUB3=""  D
-        .S (SUB4,SUB5)=0
-        .S SUB4=$O(^DGPM("ATS",ECXDFN,ECXADM,SUB3,SUB4))
-        .S SUB5=$O(^DGPM("ATS",ECXDFN,ECXADM,SUB3,SUB4,SUB5))
-        .S ECXLOC(SUB3,SUB4,SUB5)="",SPC=$G(^TMP($J,"ECXTMP",SUB4))
-        .S DATA=$G(^DGPM(SUB5,0)),PRV=$P(DATA,U,8),ATT=$P(DATA,U,19)
-        .S MOV=$P(DATA,U,14)
-        .S:PRV]"" PRV=ECXPRO_PRV S:ATT]"" ATT=ECXPRO_ATT
-        .S ECXLOC(SUB3,SUB4,SUB5)=SPC_U_PRV_U_ATT_U_MOV
-        Q
-        ;
-FINDLOC(ECXTSD,ECXLOC,ECXSPC,ECXPRV,ECXATT,ECXMOV,ECXTRT)       ;find local array node for current ts movement
-        ;   input
-        ;   ECXTSD = inverse date/time for current ts movement; required
-        ;   ECXLOC = local array; passed by reference; required
-        ;   output; data from record contained in MOVE
-        ;   ECXSPC = piece 1 of LOC (passed by reference)
-        ;   ECXPRV = piece 2 of LOC concatenated to PRO (passed by reference)
-        ;   ECXATT = piece 3 of LOC concatenated to PRO (passed by reference)
-        ;   ECXMOV = piece 4 of LOC (passed by reference)
-        ;   ECXTRT = pointer to file #45.7
-        ;
-        N SUB3,SUB4,SUB5,LOC
-        S (ECXSPC,ECXPRV,ECXATT,ECXMOV)=""
-        S SUB3=ECXTSD
-        I $D(ECXLOC(SUB3)) D
-        .S SUB4=$O(ECXLOC(SUB3,0)),SUB5=$O(ECXLOC(SUB3,SUB4,0))
-        .S LOC=ECXLOC(SUB3,SUB4,SUB5),ECXTRT=SUB4,ECXSPC=$P(LOC,U)
-        .S ECXPRV=$P(LOC,U,2),ECXATT=$P(LOC,U,3),ECXMOV=$P(LOC,U,4)
-        Q
-        ;
-SETUP   ;Set required input for ECXTRAC
-        S ECHEAD="TRT"
-        D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
-        Q
-        ;
-QUE     ; entry point for the background requeuing handled by ECXTAUTO
-        D SETUP,QUE^ECXTAUTO,^ECXKILL
-        Q
+ECXTRT ;ALB/JAP,BIR/DMA,CML,PTD-Treating Specialty Change Extract ; 04/12/2007
+ ;;3.0;DSS EXTRACTS;**1,8,17,24,33,35,39,46,49,84,107**;Dec 22, 1997;Build 9
+BEG ;entry point from option
+ D SETUP I ECFILE="" Q
+ D ^ECXTRAC,^ECXKILL
+ Q
+ ;
+START ; start package specific extract
+ N LOC,SPC,TRT,WRD
+ S QFLG=0
+ K ECXDD D FIELD^DID(405,.19,,"SPECIFIER","ECXDD")
+ S ECPRO=$E(+$P(ECXDD("SPECIFIER"),"P",2)) K ECXDD
+ K ^TMP($J,"ECXTMP") S TRT=0
+ F  S TRT=$O(^DIC(45.7,TRT)) Q:+TRT=0  S SPC=$P(^DIC(45.7,TRT,0),U,2),^TMP($J,"ECXTMP",TRT)=SPC
+ S ECED=ECED+.3,ECD=ECSD1
+ ;loop through type 6 movements to get treating specialty and provider changes
+ F  S ECD=$O(^DGPM("ATT6",ECD)),ECDA=0 Q:('ECD)!(ECD>ECED)!(QFLG)  F  S ECDA=$O(^DGPM("ATT6",ECD,ECDA)) Q:'ECDA  D  Q:QFLG
+ .I $D(^DGPM(ECDA,0)) S EC=^(0),ECXDFN=+$P(EC,U,3) D  Q:QFLG
+ ..S ECXMVD1=$P(EC,U),WRD=$P(EC,U,6)
+ ..;
+ ..;- Call sets ECXA (In/Out indicator)
+ ..Q:'$$PATDEM^ECXUTL2(ECXDFN,ECXMVD1,"1;",13)
+ ..S ECMT=$P(EC,U,18),ECXADM=$P(EC,U,14),ECXADT=$P($G(^DGPM(ECXADM,0)),U)
+ ..;skip the record if its the admission treat. spec. change for this episode of care
+ ..Q:ECXADM=$P(EC,U,24)
+ ..S (ECXLOS,ECXLOSA,ECXLOSP)="" S ECXDSSD=""
+ ..K LOC D SETLOC(ECXDFN,ECXADM,ECPRO,.LOC)
+ ..;get data for current (new) ts movement
+ ..S ECD1=9999999.9999999-ECXMVD1
+ ..D FINDLOC(ECD1,.LOC,.ECXSPCN,.ECXPRVN,.ECXATTN,.ECXMOVN,.ECXTRTN)
+ ..Q:ECXSPCN=""
+ ..S ECD2=$O(LOC(ECD1)) Q:ECD2=""
+ ..S ECXMVD2=9999999.9999999-ECD2
+ ..;get data for previous (losing) ts movement
+ ..D FINDLOC(ECD2,.LOC,.ECXSPCL,.ECXPRVL,.ECXATTL,.ECXMOVL,.ECXTRTL)
+ ..;if ts has changed, find los on losing ts
+ ..D:ECXTRTL'=ECXTRTN PREVTRT^ECXTRT1(.LOC,ECD1,ECD2,ECXTRTL,.ECXLOS)
+ ..;whether ts has changed or not, see if primary provider has changed
+ ..;dont bother if there's no data on current primary provider or no change in provider
+ ..D:(ECXPRVN'="")&(ECXPRVN'=ECXPRVL) PREVPRV^ECXTRT1(.LOC,ECD1,ECXPRVN,ECD2,.ECXPRVL,.ECXLOSP)
+ ..;whether ts has changed or not, see if attending physician has changed
+ ..;dont bother if theres no data on current attending physician or no change in attending
+ ..D:(ECXATTN'="")&(ECXATTN'=ECXATTL) PREVATT^ECXTRT1(.LOC,ECD1,ECXATTN,ECD2,.ECXATTL,.ECXLOSA)
+ ..S ECXDATE=$$ECXDATE^ECXUTL(ECXMVD1,ECXYM),ECXTIME=$$ECXTIME^ECXUTL(ECXMVD1)
+ ..S ECXADMDT=$$ECXDATE^ECXUTL(ECXADT,ECXYM),ECXADMTM=$$ECXTIME^ECXUTL(ECXADT),ECXDCDT=""
+ ..;- Production Division
+ ..S ECXPDIV=""
+ ..I ECXLOGIC>2003 S ECXPDIV=$S(WRD="":"",1:$$NPDIV(WRD))
+ ..S (ECXALNPI,ECXANNPI,ECXPLNPI,ECXPNNPI)=""
+ ..;
+ ..;- Observation patient indicator (YES/NO)
+ ..S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS)
+ ..;
+ ..;- Chg outpat with movemnt/discharge to inpat (to comply w/existing business rule)
+ ..I ECXA="O"&(ECXOBS="NO")&(ECXMVD1) S ECXA="I"
+ ..;
+ ..;- Get providers person classes
+ .. S ECXATLPC=$$PRVCLASS^ECXUTL($E(ECXATTL,2,999),ECXADT)
+ .. S ECXPRNPC=$$PRVCLASS^ECXUTL($E(ECXPRVN,2,999),ECXADT)
+ .. S ECXATNPC=$$PRVCLASS^ECXUTL($E(ECXATTN,2,999),ECXADT)
+ .. S ECXPRLPC=$$PRVCLASS^ECXUTL($E(ECXPRVL,2,999),ECXADT)
+ ..;
+ ..;- If no encounter number, don't file record
+ ..S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADT,,ECXTS,ECXOBS,ECHEAD,,)
+ ..D:ECXENC'="" FILE
+ ;for nhcu episodes with intervening asih stays, the los calculated here is not accurate,
+ ;but it never has been; this is best solution within current extract framework;
+ ;at discharge the los calculated for nhcu apisodes will be the los since admission w/o asih los subtracted;
+ ;
+ ;loop through discharges to get last treating specialty
+ S ECD=ECSD1
+ F  S ECD=$O(^DGPM("ATT3",ECD)),ECDA=0 Q:'ECD  Q:ECD>ECED  F  S ECDA=$O(^DGPM("ATT3",ECD,ECDA)) Q:'ECDA  D  Q:QFLG
+ .I $D(^DGPM(ECDA,0)) S EC=^(0),ECXDFN=+$P(EC,U,3) D  Q:QFLG
+ ..S ECXMVD1=$P(EC,U),WRD=$P(EC,U,6)
+ ..S (ECXDATE,ECXDCDT)=$$ECXDATE^ECXUTL(ECXMVD1,ECXYM),ECXTIME=$$ECXTIME^ECXUTL(ECXMVD1)
+ ..I ECXDCDT'>0 S ECXDCDT=""
+ ..S ECMT=$P(EC,U,18),ECXADM=$P(EC,U,14),ECXADT=$P($G(^DGPM(ECXADM,0)),U,1)
+ ..S (ECXTRTN,ECXSPCN,ECXPRVN,ECXATTN)="" S (ECXLOS,ECXLOSA,ECXLOSP)="" S ECXDSSD=""
+ ..K LOC D SETLOC(ECXDFN,ECXADM,ECPRO,.LOC)
+ ..S ECD1=9999999.9999999-ECXMVD1
+ ..;get ts change just before d/c
+ ..S ECD2=$O(LOC(ECD1)),ECXMVD2=9999999.9999999-ECD2
+ ..D FINDLOC(ECD2,.LOC,.ECXSPCL,.ECXPRVL,.ECXATTL,.ECXMOVL,.ECXTRTL)
+ ..;
+ ..;- Call sets ECXA (In/Out indicator) using date before discharge
+ ..Q:'$$PATDEM^ECXUTL2(ECXDFN,ECXMVD2,"1;",13)
+ ..S ECXADMDT=$$ECXDATE^ECXUTL(ECXADT,ECXYM),ECXADMTM=$$ECXTIME^ECXUTL(ECXADT)
+ ..;if closest ts change is admission ts, cant go back any further
+ ..S TRT=$O(LOC(ECD2,0)),REC=$O(LOC(ECD2,TRT,0))
+ ..I REC=ECXADM D
+ ...S X1=ECXMVD1,X2=ECXMVD2 D ^%DTC S ECXLOS=X
+ ...I ECXPRVL'="" S X1=ECXMVD1,X2=ECXMVD2 D ^%DTC S ECXLOSP=X
+ ...I ECXATTL'="" S X1=ECXMVD1,X2=ECXMVD2 D ^%DTC S ECXLOSA=X
+ ..;otherwise, need to find when change to last ts occurred
+ ..I REC'=ECXADM D
+ ...D PREVTRT^ECXTRT1(.LOC,ECD1,ECD2,ECXTRTL,.ECXLOS)
+ ...D PREVPRV^ECXTRT1(.LOC,ECD1,ECXPRVN,ECD2,.ECXPRVL,.ECXLOSP)
+ ...D PREVATT^ECXTRT1(.LOC,ECD1,ECXATTN,ECD2,.ECXATTL,.ECXLOSA)
+ ..S:ECXLOS>9999 ECXLOS=9999 S:ECXLOSA>9999 ECXLOSA=9999
+ ..S:ECXLOSP>9999 ECXLOSP=9999
+ ..;- Production Division
+ ..S ECXPDIV=""
+ ..I ECXLOGIC>2003 S ECXPDIV=$S(WRD="":"",1:$$NPDIV(WRD))
+ ..S (ECXALNPI,ECXANNPI,ECXPLNPI,ECXPNNPI)=""
+ ..;
+ ..;- Observation patient indicator (YES/NO)
+ ..S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS)
+ ..;
+ ..;- Chg outpat with movemnt/discharge to inpat (to comply w/existing business rule)
+ ..I ECXA="O"&(ECXOBS="NO")&(ECXMVD1) S ECXA="I"
+ ..;
+ ..;- Get providers person classes
+ .. S ECXATLPC=$$PRVCLASS^ECXUTL($E(ECXATTL,2,999),ECXADT)
+ .. S ECXPRNPC=$$PRVCLASS^ECXUTL($E(ECXPRVN,2,999),ECXADT)
+ .. S ECXATNPC=$$PRVCLASS^ECXUTL($E(ECXATTN,2,999),ECXADT)
+ .. S ECXPRLPC=$$PRVCLASS^ECXUTL($E(ECXPRVL,2,999),ECXADT)
+ ..;
+ ..;- If no encounter number don't file record
+ ..S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADT,,ECXTS,ECXOBS,ECHEAD,,)
+ ..D:ECXENC'="" FILE
+ D KPATDEM^ECXUTL2
+ Q
+ ;
+NPDIV(WRD) ;National Production Division
+ N DIV
+ S DIV=$$GET1^DIQ(42,WRD,.015,"I")
+ Q $S(DIV="":"",1:$$GETDIV^ECXDEPT(DIV))
+ ;
+SETLOC(ECXDFN,ECXADM,ECXPRO,ECXLOC) ;setup the local array from the ATS index
+ ; output
+ ; ECXLOC = local array (passed by reference)
+ ;
+ N SUB3,SUB4,SUB5,SPC,PRV,ATT,MOV
+ S SUB3=0
+ F  S SUB3=$O(^DGPM("ATS",ECXDFN,ECXADM,SUB3)) Q:SUB3=""  D
+ .S (SUB4,SUB5)=0
+ .S SUB4=$O(^DGPM("ATS",ECXDFN,ECXADM,SUB3,SUB4))
+ .S SUB5=$O(^DGPM("ATS",ECXDFN,ECXADM,SUB3,SUB4,SUB5))
+ .S ECXLOC(SUB3,SUB4,SUB5)="",SPC=$G(^TMP($J,"ECXTMP",SUB4))
+ .S DATA=$G(^DGPM(SUB5,0)),PRV=$P(DATA,U,8),ATT=$P(DATA,U,19)
+ .S MOV=$P(DATA,U,14)
+ .S:PRV]"" PRV=ECXPRO_PRV S:ATT]"" ATT=ECXPRO_ATT
+ .S ECXLOC(SUB3,SUB4,SUB5)=SPC_U_PRV_U_ATT_U_MOV
+ Q
+ ;
+FINDLOC(ECXTSD,ECXLOC,ECXSPC,ECXPRV,ECXATT,ECXMOV,ECXTRT) ;find local array node for current ts movement
+ ;   input
+ ;   ECXTSD = inverse date/time for current ts movement; required
+ ;   ECXLOC = local array; passed by reference; required
+ ;   output; data from record contained in MOVE
+ ;   ECXSPC = piece 1 of LOC (passed by reference)
+ ;   ECXPRV = piece 2 of LOC concatenated to PRO (passed by reference)
+ ;   ECXATT = piece 3 of LOC concatenated to PRO (passed by reference)
+ ;   ECXMOV = piece 4 of LOC (passed by reference)
+ ;   ECXTRT = pointer to file #45.7
+ ;
+ N SUB3,SUB4,SUB5,LOC
+ S (ECXSPC,ECXPRV,ECXATT,ECXMOV)=""
+ S SUB3=ECXTSD
+ I $D(ECXLOC(SUB3)) D
+ .S SUB4=$O(ECXLOC(SUB3,0)),SUB5=$O(ECXLOC(SUB3,SUB4,0))
+ .S LOC=ECXLOC(SUB3,SUB4,SUB5),ECXTRT=SUB4,ECXSPC=$P(LOC,U)
+ .S ECXPRV=$P(LOC,U,2),ECXATT=$P(LOC,U,3),ECXMOV=$P(LOC,U,4)
+ Q
+ ;
+FILE ;file the extract record
+ ;node0
+ ;^dfn^ssn^name^i/o (ECXA)^date^product^adm date^d/c date^
+ ;mov#^type^new ts^losing ts^losing ts los^
+ ;losing attending^movement type^time^adm time^new provider^
+ ;new attending^losing provider
+ ;node1
+ ;mpi^dss dept^losing attending npi^new provider npi^new attending npi^
+ ;losing provider npi^losing attending los^losing provider los^dom^
+ ;observ pat ind^encounter num
+ ;
+ ;convert specialties to PTF Codes for transmission
+ ;
+ N ECXDATA
+ S ECXDATA=$$TSDATA^DGACT(42.4,+ECXSPCN,.ECXDATA)
+ S ECXSPCN=$G(ECXDATA(7))
+ S ECXDATA=$$TSDATA^DGACT(42.4,+ECXSPCL,.ECXDATA)
+ S ECXSPCL=$G(ECXDATA(7))
+ ;done
+ S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1
+ S ECODE=EC7_U_EC23_U_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U_ECXDATE_U_U
+ S ECODE=ECODE_ECXADMDT_U_ECXDCDT_U_ECDA_U_6_U_ECXSPCN_U_ECXSPCL_U
+ S ECODE=ECODE_ECXLOS_U_ECXATTL_U_ECMT_U_ECXTIME_U_ECXADMTM_U_ECXPRVN_U
+ S ECODE=ECODE_ECXATTN_U_ECXPRVL_U
+ S ECODE1=ECXMPI_U_ECXDSSD_U_ECXALNPI_U_ECXPNNPI_U_ECXANNPI_U_ECXPLNPI_U
+ S ECODE1=ECODE1_ECXLOSA_U_ECXLOSP_U_ECXDOM_U_ECXOBS_U_ECXENC_U_ECXPDIV
+ I ECXLOGIC>2005 S ECODE1=ECODE1_U_ECXATLPC_U_ECXPRNPC_U_ECXATNPC_U_ECXPRLPC
+ S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,ECRN=ECRN+1
+ S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA
+ I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1
+ Q
+ ;
+SETUP ;Set required input for ECXTRAC
+ S ECHEAD="TRT"
+ D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
+ Q
+ ;
+QUE ; entry point for the background requeuing handled by ECXTAUTO
+ D SETUP,QUE^ECXTAUTO,^ECXKILL
+ Q

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXUD.m

@@ -1 @@
-ECXUD   ;ALB/JAP,BIR/DMA,PTD-Extract from UNIT DOSE EXTRACT DATA File (#728.904) ; 10/31/07 1:58pm
-        ;;3.0;DSS EXTRACTS;**10,8,24,33,39,46,49,71,84,92,107,105**;Dec 22, 1997;Build 70
-BEG     ;entry point from option
-        I '$O(^ECX(728.904,"A",0)) W !,"There are no unit dose orders to extract",!! R X:5 K X Q
-        D SETUP I ECFILE="" Q
-        D ^ECXTRAC,^ECXKILL
-        Q
-        ;
-START   ;start package specific extract
-        S QFLG=0
-        S ECED=ECED+.3
-        F ECD=ECSD1:0 S ECD=$O(^ECX(728.904,"A",ECD)) Q:'ECD  Q:ECD>ECED  Q:QFLG  D
-        .S ECXJ=0 F  S ECXJ=$O(^ECX(728.904,"A",ECD,ECXJ)) Q:'ECXJ  Q:QFLG  I $D(^ECX(728.904,ECXJ,0)) D
-        ..S DATA=^ECX(728.904,ECXJ,0),^(1)=$P(EC23,U,2),^ECX(728.904,"AC",$P(EC23,U,2),ECXJ)="" D STUFF
-        K ^TMP($J,"ECXP")
-        Q
-        ;
-STUFF   ;get data
-        N X,W,OK,P1,P3,PSTAT,PT,ECXPHA,ON,ECDRG
-        S ECXDFN=$P(DATA,U,2),ECDRG=$P(DATA,U,4)
-        ;
-        ;get patient specific data
-        S ECXERR="" D PAT(ECXDFN,ECD,.ECXERR)
-        Q:ECXERR
-        ;
-        S ECXPRO=$P(DATA,U,7),ECPROIEN=+ECXPRO,ECXPRO=$E($P(ECXPRO,";",2))_$P(ECXPRO,";")
-        S ECXPRNPI=$$NPI^XUSNPI("Individual_ID",ECPROIEN,ECD)
-        S:+ECXPRNPI'>0 ECXPRNPI="" S ECXPRNPI=$P(ECXPRNPI,U)
-        S W=$P(DATA,U,6)
-        S ECXDIV=$P($G(^DIC(42,+W,0)),U,11),ECXW=$P($G(^DIC(42,+W,44)),U)
-        S ECXUDDT=$$ECXDATE^ECXUTL($P(DATA,U,3),ECXYM)
-        S ECXUDTM=$E($P($P(DATA,U,3),".",2)_"000000",1,6)
-        S ECXQTY=$P(DATA,U,5),ECXCOST=$P(DATA,U,8),ON=$P(DATA,U,10)
-        ;call pharmacy drug file (#50) api via ecxutl5
-        S ECXPHA=$$PHAAPI^ECXUTL5(ECDRG)
-        S ECCAT=$P(ECXPHA,U,2),ECINV=$P(ECXPHA,U,4)
-        S ECINV=$S(ECINV["I":"I",1:"")
-        S ECNDC=$P(ECXPHA,U,3)
-        S ECNFC=$$RJ^XLFSTR($P(ECNDC,"-"),6,0)_$$RJ^XLFSTR($P(ECNDC,"-",2),4,0)_$$RJ^XLFSTR($P(ECNDC,"-",3),2,0),ECNFC=$TR(ECNFC,"*",0)
-        S P1=$P(ECXPHA,U,5),P3=$P(ECXPHA,U,6),X="PSNAPIS"
-        X ^%ZOSF("TEST") I $T S ECNFC=$$DSS^PSNAPIS(P1,P3,ECXYM)_ECNFC
-        I $L(ECNFC)=12 S ECNFC=$$RJ^XLFSTR(P1,4,0)_$$RJ^XLFSTR(P3,3,0)_ECNFC
-        ; - Department and National Production Division
-        ;- Use of DSS Department postponed [S ECXDSSD=$$UDP^ECXDEPT(ECXDIV)]
-        S ECXDSSD=""
-        S ECXPDIV=$$GETDIV^ECXDEPT(ECXDIV)
-        ;- Observation patient indicator (YES/NO)
-        S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS)
-        ;- Ordering Date, Ordering Stop Code
-        S ECXORDDT=$TR($$FMTE^XLFDT($P(DATA,U,9),"7DF")," /","0")
-        S ECXORDST="" I ECXA="O" D
-        .;Get ordering stop code based on FY 2006 logic for outpatient
-        .S ECXORDST=$$DOUDO^ECXUTL5(ECXDFN,ON)
-        ;Ordering Provider Person Class
-        S ECXOPPC=$$PRVCLASS^ECXUTL($E(ECXPRO,2,999),$P(DATA,U,9))
-        ;BCMA data (place holder)
-        S (ECXBCDD,ECXBCDG,ECXBCUA,ECXBCIF)=""
-        ;- Set national patient record flag if exist
-        D NPRF^ECXUTL5
-        ;- If no encounter number don't file record
-        S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADM,$P(DATA,U,3),ECXTS,ECXOBS,ECHEAD,,)
-        D:ECXENC'="" FILE
-        Q
-        ;
-PAT(ECXDFN,ECXDATE,ECXERR)      ;get demographics from patient file
-        ;init variables
-        S (ECXCAT,ECXSTAT,ECXPRIOR,ECXSBGRP,ECXOEF,ECXOEFDT)=""
-        ;get patient data if saved
-        I $D(^TMP($J,"ECXP",ECXDFN)) D
-        .S PT=^TMP($J,"ECXP",ECXDFN),ECXPNM=$P(PT,U),ECXSSN=$P(PT,U,2)
-        .S ECXMPI=$P(PT,U,3),ECXDOB=$P(PT,U,4)
-        .S ECXELIG=$P(PT,U,5),ECXSEX=$P(PT,U,6)
-        .S ECXSTATE=$P(PT,U,7),ECXCNTY=$P(PT,U,8),ECXZIP=$P(PT,U,9)
-        .S ECXVET=$P(PT,U,10),ECXPOS=$P(PT,U,11),ECXPST=$P(PT,U,12)
-        .S ECXPLOC=$P(PT,U,13),ECXRST=$P(PT,U,14),ECXAST=$P(PT,U,15)
-        .S ECXAOL=$P(PT,U,16),ECXPHI=$P(PT,U,17),ECXMST=$P(PT,U,18)
-        .S ECXENRL=$P(PT,U,19),ECXCNHU=$P(PT,U,20),ECXCAT=$P(PT,U,21)
-        .S ECXSTAT=$P(PT,U,22),ECXPRIOR=$P(PT,U,23),ECXHNCI=$P(PT,U,24)
-        .S ECXETH=$P(PT,U,25),ECXRC1=$P(PT,U,26),ECXMTST=$P(PT,U,27)
-        .S PT1=$G(^TMP($J,"ECXP",ECXDFN,1)),ECXERI=$P(PT1,U),ECXEST=$P(PT1,U,2),ECXOEF=$P(PT1,U,3),ECXOEFDT=$P(PT1,U,4)
-        .I $$ENROLLM^ECXUTL2(ECXDFN)
-        ;set patient data
-        I '$D(^TMP($J,"ECXP",ECXDFN)) D  Q:'OK
-        .K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECXDATE,"."),"1;2;3;5",.ECXPAT)
-        .I 'OK K ECXPAT S ECXERR=1 Q
-        .S ECXPNM=ECXPAT("NAME"),ECXSSN=ECXPAT("SSN"),ECXMPI=ECXPAT("MPI")
-        .S ECXDOB=ECXPAT("DOB"),ECXELIG=ECXPAT("ELIG"),ECXSEX=ECXPAT("SEX")
-        .S ECXSTATE=ECXPAT("STATE"),ECXCNTY=ECXPAT("COUNTY")
-        .S ECXZIP=ECXPAT("ZIP"),ECXVET=ECXPAT("VET")
-        .S ECXPOS=ECXPAT("POS"),ECXPST=ECXPAT("POW STAT")
-        .S ECXPLOC=ECXPAT("POW LOC"),ECXRST=ECXPAT("IR STAT")
-        .S ECXAST=ECXPAT("AO STAT"),ECXAOL=ECXPAT("AOL")
-        .S ECXPHI=ECXPAT("PHI"),ECXMST=ECXPAT("MST STAT")
-        .S ECXENRL=ECXPAT("ENROLL LOC"),ECXMTST=ECXPAT("MEANS")
-        .;OEF/OIF data
-        .S ECXOEF=ECXPAT("ECXOEF")
-        .S ECXOEFDT=ECXPAT("ECXOEFDT")
-        .;get CNHU status
-        .S ECXCNHU=$$CNHSTAT^ECXUTL4(ECXDFN)
-        .;get enrollment data (category, status and priority)
-        .I $$ENROLLM^ECXUTL2(ECXDFN)
-        .; - Head and Neck Cancer Indicator
-        .S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN)
-        .; - Race and Ethnicity
-        .S ECXETH=ECXPAT("ETHNIC")
-        .S ECXRC1=ECXPAT("RACE1")
-        .;get emergency response indicator (FEMA)
-        .S ECXERI=ECXPAT("ERI")
-        .S ECXEST=ECXPAT("EC STAT")
-        .;save for later
-        .S ^TMP($J,"ECXP",ECXDFN)=ECXPNM_U_ECXSSN_U_ECXMPI_U_ECXDOB_U_ECXELIG_U_ECXSEX_U_ECXSTATE_U_ECXCNTY_U_ECXZIP_U_ECXVET_U_ECXPOS_U_ECXPST_U_ECXPLOC_U_ECXRST_U_ECXAST
-        .S ^TMP($J,"ECXP",ECXDFN)=^TMP($J,"ECXP",ECXDFN)_U_ECXAOL_U_ECXPHI_U_ECXMST_U_ECXENRL_U_ECXCNHU_U_ECXCAT_U_ECXSTAT_U_ECXPRIOR_U_ECXHNCI_U_ECXETH_U_ECXRC1_U_ECXMTST
-        .S ^TMP($J,"ECXP",ECXDFN,1)=ECXERI_U_ECXEST_U_ECXOEF_U_ECXOEFDT
-        ;
-        ;get inpatient data
-        S X=$$INP^ECXUTL2(ECXDFN,ECXDATE),ECXA=$P(X,U),ECXMN=$P(X,U,2)
-        S ECXTS=$P(X,U,3),ECXADM=$P(X,U,4),ECXDOM=$P(X,U,10)
-        ;
-        ;get primary care data
-        S X=$$PRIMARY^ECXUTL2(ECXDFN,$P(ECXDATE,"."))
-        S ECPTTM=$P(X,U),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4)
-        S ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7)
-        Q
-        ;
-FILE    ;file record
-        ;node0
-        ;facility^dfn^ssn^name^in/out^day^drug category^quantity^ward^
-        ;provider^cost^mov #^treat spec^ndc^new feeder key^investigational^
-        ;udp time^adm date^adm time
-        ;node1
-        ;mpi^dss dept^provider npi^dom^observ pat ind^encounter num^
-        ;prod div code^means tst^elig^dob^sex^state^county^zip+4^vet^
-        ;period of svc^pow stat^pow loc^ir status^ao status^ao loc^
-        ;purple heart ind.^mst status^cnh/sh status^enrollment loc^
-        ;enrollment cat^enrollment status^enrollment priority^pc team^
-        ;pc provider^pc provider npi^pc provider p.class^assoc. pc provider^
-        ;assoc. pc provider npi^assoc. pc provider p.class
-        ;node2
-        ;ordering date^ordering stop code^head & neck cancer ind.^ethnicity^
-        ;race1^bcma drug dispensed^bcma dose given^bcma unit of
-        ;administration^bcma icu flag^ordering provider person class^
-        ;^enrollment priority ECXPRIOR_enrollment subgroup
-        ;ECXSBGRP^user enrollee ECXUESTA^patient type ECXPTYPE^combat vet
-        ;elig ECXCVE^combat vet elig end date ECXCVEDT^enc cv eligible
-        ;ECXCVENC^national patient record flag ECXNPRFI^emerg resp indic(FEMA) 
-        ;ECXERI^environ contamin ECXEST^OEF/OIF ECXOEF^OEF/OIF return date ECXOEFDT^associate pc provider npi ECASNPI^primary care provider npi ECPTNPI^provider npi ECXPRNPI
-        N DA,DIK
-        S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1
-        S ECODE=EC7_U_EC23_U_ECXDIV_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U
-        S ECODE=ECODE_ECXUDDT_U_ECCAT_U_ECXQTY_U_ECXW_U_ECXPRO_U_ECXCOST_U
-        S ECODE=ECODE_ECXMN_U_ECXTS_U_ECNDC_U_ECNFC_U_ECINV_U_ECXUDTM_U
-        ;convert specialty to PTF Code for transmission
-        N ECXDATA
-        S ECXDATA=$$TSDATA^DGACT(42.4,+ECXTS,.ECXDATA)
-        S ECXTS=$G(ECXDATA(7))
-        ;done
-        S ECODE=ECODE_$$ECXDATE^ECXUTL(ECXADM,ECXYM)_U
-        S ECODE=ECODE_$$ECXTIME^ECXUTL(ECXADM)_U
-        S ECODE1=ECXMPI_U_ECXDSSD_U_U_ECXDOM_U_ECXOBS_U_ECXENC_U
-        S ECODE1=ECODE1_ECXPDIV_U_ECXMTST_U_ECXELIG_U_ECXDOB_U_ECXSEX_U
-        S ECODE1=ECODE1_ECXSTATE_U_ECXCNTY_U_ECXZIP_U_ECXVET_U_ECXPOS_U
-        S ECODE1=ECODE1_ECXPST_U_ECXPLOC_U_ECXRST_U_ECXAST_U
-        S ECODE1=ECODE1_ECXAOL_U_ECXPHI_U_ECXMST_U_ECXCNHU_U_ECXENRL_U
-        S ECODE1=ECODE1_ECXCAT_U_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECPTTM_U_ECPTPR_U
-        S ECODE1=ECODE1_U_ECCLAS_U_ECASPR_U_U_ECCLAS2_U
-        S ECODE2=ECXORDDT_U_ECXORDST_U_ECXHNCI_U_ECXETH_U_ECXRC1
-        I ECXLOGIC>2003 S ECODE2=ECODE2_U_ECXBCDD_U_ECXBCDG_U_ECXBCUA_U_ECXBCIF_U_ECXOPPC
-        I ECXLOGIC>2004 S ECODE2=ECODE2_U_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXNPRFI
-        I ECXLOGIC>2006 S ECODE2=ECODE2_U_ECXERI_U_ECXEST
-        I ECXLOGIC>2007 S ECODE2=ECODE2_U_ECXOEF_U_ECXOEFDT_U_ECASNPI_U_ECPTNPI_U_ECXPRNPI
-        S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1
-        S ^ECX(ECFILE,EC7,2)=ECODE2,ECRN=ECRN+1
-        S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA
-        I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1
-        Q
-        ;
-SETUP   ;Set required input for ECXTRAC
-        S ECHEAD="UDP"
-        D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
-        Q
-        ;
-QUE     ; entry point for the background requeuing handled by ECXTAUTO
-        D SETUP,QUE^ECXTAUTO,^ECXKILL
-        Q
+ECXUD ;ALB/JAP,BIR/DMA,PTD-Extract from UNIT DOSE EXTRACT DATA File (#728.904) ;4/19/2007
+ ;;3.0;DSS EXTRACTS;**10,8,24,33,39,46,49,71,84,92,107**;Dec 22, 1997;Build 9
+BEG ;entry point from option
+ I '$O(^ECX(728.904,"A",0)) W !,"There are no unit dose orders to extract",!! R X:5 K X Q
+ D SETUP I ECFILE="" Q
+ D ^ECXTRAC,^ECXKILL
+ Q
+ ;
+START ;start package specific extract
+ S QFLG=0
+ S ECED=ECED+.3
+ F ECD=ECSD1:0 S ECD=$O(^ECX(728.904,"A",ECD)) Q:'ECD  Q:ECD>ECED  Q:QFLG  D
+ .S ECXJ=0 F  S ECXJ=$O(^ECX(728.904,"A",ECD,ECXJ)) Q:'ECXJ  Q:QFLG  I $D(^ECX(728.904,ECXJ,0)) D
+ ..S DATA=^ECX(728.904,ECXJ,0),^(1)=$P(EC23,U,2),^ECX(728.904,"AC",$P(EC23,U,2),ECXJ)="" D STUFF
+ K ^TMP($J,"ECXP")
+ Q
+ ;
+STUFF ;get data
+ N X,W,OK,P1,P3,PSTAT,PT,ECXPHA,ON,ECDRG
+ S ECXDFN=$P(DATA,U,2),ECDRG=$P(DATA,U,4)
+ ;
+ ;get patient specific data
+ S ECXERR="" D PAT(ECXDFN,ECD,.ECXERR)
+ Q:ECXERR
+ ;
+ S ECXPRO=$P(DATA,U,7),ECXPRO=$E($P(ECXPRO,";",2))_$P(ECXPRO,";")
+ S ECXPRNPI="",W=$P(DATA,U,6)
+ S ECXDIV=$P($G(^DIC(42,+W,0)),U,11),ECXW=$P($G(^DIC(42,+W,44)),U)
+ S ECXUDDT=$$ECXDATE^ECXUTL($P(DATA,U,3),ECXYM)
+ S ECXUDTM=$E($P($P(DATA,U,3),".",2)_"000000",1,6)
+ S ECXQTY=$P(DATA,U,5),ECXCOST=$P(DATA,U,8),ON=$P(DATA,U,10)
+ ;call pharmacy drug file (#50) api via ecxutl5
+ S ECXPHA=$$PHAAPI^ECXUTL5(ECDRG)
+ S ECCAT=$P(ECXPHA,U,2),ECINV=$P(ECXPHA,U,4)
+ S ECINV=$S(ECINV["I":"I",1:"")
+ S ECNDC=$P(ECXPHA,U,3)
+ S ECNFC=$$RJ^XLFSTR($P(ECNDC,"-"),6,0)_$$RJ^XLFSTR($P(ECNDC,"-",2),4,0)_$$RJ^XLFSTR($P(ECNDC,"-",3),2,0),ECNFC=$TR(ECNFC,"*",0)
+ S P1=$P(ECXPHA,U,5),P3=$P(ECXPHA,U,6),X="PSNAPIS"
+ X ^%ZOSF("TEST") I $T S ECNFC=$$DSS^PSNAPIS(P1,P3,ECXYM)_ECNFC
+ I $L(ECNFC)=12 S ECNFC=$$RJ^XLFSTR(P1,4,0)_$$RJ^XLFSTR(P3,3,0)_ECNFC
+ ; - Department and National Production Division
+ ;- Use of DSS Department postponed [S ECXDSSD=$$UDP^ECXDEPT(ECXDIV)]
+ S ECXDSSD=""
+ S ECXPDIV=$$GETDIV^ECXDEPT(ECXDIV)
+ ;- Observation patient indicator (YES/NO)
+ S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS)
+ ;- Ordering Date, Ordering Stop Code
+ S ECXORDDT=$TR($$FMTE^XLFDT($P(DATA,U,9),"7DF")," /","0")
+ S ECXORDST="" I ECXA="O" D
+ .;Get ordering stop code based on FY 2006 logic for outpatient
+ .S ECXORDST=$$DOUDO^ECXUTL5(ECXDFN,ON)
+ ;Ordering Provider Person Class
+ S ECXOPPC=$$PRVCLASS^ECXUTL($E(ECXPRO,2,999),$P(DATA,U,9))
+ ;BCMA data (place holder)
+ S (ECXBCDD,ECXBCDG,ECXBCUA,ECXBCIF)=""
+ ;- Set national patient record flag if exist
+ D NPRF^ECXUTL5
+ ;- If no encounter number don't file record
+ S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADM,$P(DATA,U,3),ECXTS,ECXOBS,ECHEAD,,)
+ D:ECXENC'="" FILE
+ Q
+ ;
+PAT(ECXDFN,ECXDATE,ECXERR) ;get demographics from patient file
+ ;init variables
+ S (ECXCAT,ECXSTAT,ECXPRIOR,ECXSBGRP)=""
+ ;get patient data if saved
+ I $D(^TMP($J,"ECXP",ECXDFN)) D
+ .S PT=^TMP($J,"ECXP",ECXDFN),ECXPNM=$P(PT,U),ECXSSN=$P(PT,U,2)
+ .S ECXMPI=$P(PT,U,3),ECXDOB=$P(PT,U,4)
+ .S ECXELIG=$P(PT,U,5),ECXSEX=$P(PT,U,6)
+ .S ECXSTATE=$P(PT,U,7),ECXCNTY=$P(PT,U,8),ECXZIP=$P(PT,U,9)
+ .S ECXVET=$P(PT,U,10),ECXPOS=$P(PT,U,11),ECXPST=$P(PT,U,12)
+ .S ECXPLOC=$P(PT,U,13),ECXRST=$P(PT,U,14),ECXAST=$P(PT,U,15)
+ .S ECXAOL=$P(PT,U,16),ECXPHI=$P(PT,U,17),ECXMST=$P(PT,U,18)
+ .S ECXENRL=$P(PT,U,19),ECXCNHU=$P(PT,U,20),ECXCAT=$P(PT,U,21)
+ .S ECXSTAT=$P(PT,U,22),ECXPRIOR=$P(PT,U,23),ECXHNCI=$P(PT,U,24)
+ .S ECXETH=$P(PT,U,25),ECXRC1=$P(PT,U,26),ECXMTST=$P(PT,U,27)
+ .S PT1=$G(^TMP($J,"ECXP",ECXDFN,1)),ECXERI=$P(PT1,U),ECXEST=$P(PT1,U,2)
+ .I $$ENROLLM^ECXUTL2(ECXDFN)
+ ;set patient data
+ I '$D(^TMP($J,"ECXP",ECXDFN)) D  Q:'OK
+ .K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECXDATE,"."),"1;2;3;5",.ECXPAT)
+ .I 'OK K ECXPAT S ECXERR=1 Q
+ .S ECXPNM=ECXPAT("NAME"),ECXSSN=ECXPAT("SSN"),ECXMPI=ECXPAT("MPI")
+ .S ECXDOB=ECXPAT("DOB"),ECXELIG=ECXPAT("ELIG"),ECXSEX=ECXPAT("SEX")
+ .S ECXSTATE=ECXPAT("STATE"),ECXCNTY=ECXPAT("COUNTY")
+ .S ECXZIP=ECXPAT("ZIP"),ECXVET=ECXPAT("VET")
+ .S ECXPOS=ECXPAT("POS"),ECXPST=ECXPAT("POW STAT")
+ .S ECXPLOC=ECXPAT("POW LOC"),ECXRST=ECXPAT("IR STAT")
+ .S ECXAST=ECXPAT("AO STAT"),ECXAOL=ECXPAT("AOL")
+ .S ECXPHI=ECXPAT("PHI"),ECXMST=ECXPAT("MST STAT")
+ .S ECXENRL=ECXPAT("ENROLL LOC"),ECXMTST=ECXPAT("MEANS")
+ .;get CNHU status
+ .S ECXCNHU=$$CNHSTAT^ECXUTL4(ECXDFN)
+ .;get enrollment data (category, status and priority)
+ .I $$ENROLLM^ECXUTL2(ECXDFN)
+ .; - Head and Neck Cancer Indicator
+ .S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN)
+ .; - Race and Ethnicity
+ .S ECXETH=ECXPAT("ETHNIC")
+ .S ECXRC1=ECXPAT("RACE1")
+ .;get emergency response indicator (FEMA)
+ .S ECXERI=ECXPAT("ERI")
+ .S ECXEST=ECXPAT("EC STAT")
+ .;save for later
+ .S ^TMP($J,"ECXP",ECXDFN)=ECXPNM_U_ECXSSN_U_ECXMPI_U_ECXDOB_U_ECXELIG_U_ECXSEX_U_ECXSTATE_U_ECXCNTY_U_ECXZIP_U_ECXVET_U_ECXPOS_U_ECXPST_U_ECXPLOC_U_ECXRST_U_ECXAST
+ .S ^TMP($J,"ECXP",ECXDFN)=^TMP($J,"ECXP",ECXDFN)_U_ECXAOL_U_ECXPHI_U_ECXMST_U_ECXENRL_U_ECXCNHU_U_ECXCAT_U_ECXSTAT_U_ECXPRIOR_U_ECXHNCI_U_ECXETH_U_ECXRC1_U_ECXMTST
+ .S ^TMP($J,"ECXP",ECXDFN,1)=ECXERI_U_ECXEST
+ ;
+ ;get inpatient data
+ S X=$$INP^ECXUTL2(ECXDFN,ECXDATE),ECXA=$P(X,U),ECXMN=$P(X,U,2)
+ S ECXTS=$P(X,U,3),ECXADM=$P(X,U,4),ECXDOM=$P(X,U,10)
+ ;
+ ;get primary care data
+ S X=$$PRIMARY^ECXUTL2(ECXDFN,$P(ECXDATE,"."))
+ S ECPTTM=$P(X,U),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3),ECPTNPI=$P(X,U,4)
+ S ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6),ECASNPI=$P(X,U,7)
+ Q
+ ;
+FILE ;file record
+ ;node0
+ ;facility^dfn^ssn^name^in/out^day^drug category^quantity^ward^
+ ;provider^cost^mov #^treat spec^ndc^new feeder key^investigational^
+ ;udp time^adm date^adm time
+ ;node1
+ ;mpi^dss dept^provider npi^dom^observ pat ind^encounter num^
+ ;prod div code^means tst^elig^dob^sex^state^county^zip+4^vet^
+ ;period of svc^pow stat^pow loc^ir status^ao status^ao loc^
+ ;purple heart ind.^mst status^cnh/sh status^enrollment loc^
+ ;enrollment cat^enrollment status^enrollment priority^pc team^
+ ;pc provider^pc provider npi^pc provider p.class^assoc. pc provider^
+ ;assoc. pc provider npi^assoc. pc provider p.class
+ ;node2
+ ;ordering date^ordering stop code^head & neck cancer ind.^ethnicity^
+ ;race1^bcma drug dispensed^bcma dose given^bcma unit of
+ ;administration^bcma icu flag^ordering provider person class^
+ ;^enrollment priority ECXPRIOR_enrollment subgroup
+ ;ECXSBGRP^user enrollee ECXUESTA^patient type ECXPTYPE^combat vet
+ ;elig ECXCVE^combat vet elig end date ECXCVEDT^enc cv eligible
+ ;ECXCVENC^national patient record flag ECXNPRFI^emerg resp indic(FEMA) 
+ ;ECXERI^environ contamin ECXEST
+ N DA,DIK
+ S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1
+ S ECODE=EC7_U_EC23_U_ECXDIV_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U
+ S ECODE=ECODE_ECXUDDT_U_ECCAT_U_ECXQTY_U_ECXW_U_ECXPRO_U_ECXCOST_U
+ S ECODE=ECODE_ECXMN_U_ECXTS_U_ECNDC_U_ECNFC_U_ECINV_U_ECXUDTM_U
+ ;convert specialty to PTF Code for transmission
+ N ECXDATA
+ S ECXDATA=$$TSDATA^DGACT(42.4,+ECXTS,.ECXDATA)
+ S ECXTS=$G(ECXDATA(7))
+ ;done
+ S ECODE=ECODE_$$ECXDATE^ECXUTL(ECXADM,ECXYM)_U
+ S ECODE=ECODE_$$ECXTIME^ECXUTL(ECXADM)_U
+ S ECODE1=ECXMPI_U_ECXDSSD_U_ECXPRNPI_U_ECXDOM_U_ECXOBS_U_ECXENC_U
+ S ECODE1=ECODE1_ECXPDIV_U_ECXMTST_U_ECXELIG_U_ECXDOB_U_ECXSEX_U
+ S ECODE1=ECODE1_ECXSTATE_U_ECXCNTY_U_ECXZIP_U_ECXVET_U_ECXPOS_U
+ S ECODE1=ECODE1_ECXPST_U_ECXPLOC_U_ECXRST_U_ECXAST_U
+ S ECODE1=ECODE1_ECXAOL_U_ECXPHI_U_ECXMST_U_ECXCNHU_U_ECXENRL_U
+ S ECODE1=ECODE1_ECXCAT_U_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECPTTM_U_ECPTPR_U
+ S ECODE1=ECODE1_ECPTNPI_U_ECCLAS_U_ECASPR_U_ECASNPI_U_ECCLAS2_U
+ S ECODE2=ECXORDDT_U_ECXORDST_U_ECXHNCI_U_ECXETH_U_ECXRC1
+ I ECXLOGIC>2003 S ECODE2=ECODE2_U_ECXBCDD_U_ECXBCDG_U_ECXBCUA_U_ECXBCIF_U_ECXOPPC
+ I ECXLOGIC>2004 S ECODE2=ECODE2_U_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXNPRFI
+ I ECXLOGIC>2006 S ECODE2=ECODE2_U_ECXERI_U_ECXEST
+ S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1
+ S ^ECX(ECFILE,EC7,2)=ECODE2,ECRN=ECRN+1
+ S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA
+ I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1
+ Q
+ ;
+SETUP ;Set required input for ECXTRAC
+ S ECHEAD="UDP"
+ D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
+ Q
+ ;
+QUE ; entry point for the background requeuing handled by ECXTAUTO
+ D SETUP,QUE^ECXTAUTO,^ECXKILL
+ Q

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXUPRO.m

@@ -1 @@
-ECXUPRO ;ALB/TJL-Prosthetic Extract Unusual Cost Report ; 1/08/08 1:00pm
-        ;;3.0;DSS EXTRACTS;**49,111**;July 1, 2003;Build 4
-        ;
-EN      ; entry point
-        N X,Y,DATE,ECRUN,ECXDESC,ECXSAVE,ECXTL,ECTHLD
-        N ECINST,ECSD,ECSD1,ECSTART,ECED,ECEND,ECXERR,QFLG
-        S QFLG=0
-        S ECINST=$$PDIV^ECXPUTL
-        ; get today's date
-        D NOW^%DTC S DATE=X,Y=$E(%,1,12) D DD^%DT S ECRUN=$P(Y,"@") K %DT
-        D BEGIN Q:QFLG
-        D SELECT Q:QFLG
-        S ECXDESC="Prosthetic Extract Unusual Cost Report"
-        S ECXSAVE("EC*")=""
-        W !!,"This report requires 132-column format."
-        D EN^XUTMDEVQ("PROCESS^ECXUPRO",ECXDESC,.ECXSAVE)
-        I POP W !!,"No device selected...exiting.",! Q
-        I IO'=IO(0) D ^%ZISC
-        D HOME^%ZIS
-        D AUDIT^ECXKILL
-        Q
-        ;
-BEGIN   ; display report description
-        W @IOF
-        W !,"This report prints a listing of unusual costs that would be"
-        W !,"generated by the Prosthetic extract (PRO) as determined by a"
-        W !,"user-defined threshold value.  It should be run prior to the"
-        W !,"generation of the actual extract(s) to identify and fix, as"
-        W !,"necessary, any costs determined to be erroneous."
-        W !!,"Unusual costs are those where the Cost of Transaction is"
-        W !,"greater than the threshold value."
-        W !!,"Note: The threshold can be set after a report is selected."
-        W !!,"Run times for this report will vary depending upon the size of"
-        W !,"the extract and could take as long as 30 minutes or more to"
-        W !,"complete.  This report has no effect on the actual extracts and"
-        W !,"can be run as needed."
-        W !!,"The report is sorted by Feeder Key, then by descending Cost of"
-        W !,"Transaction and SSN."
-        S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q
-        W:$Y!($E(IOST)="C") @IOF,!!
-        Q
-        ;
-SELECT  ; user inputs for threshold cost and date range
-        N DONE,OUT
-        ; allow user to set threshold cost
-        S ECTHLD=500
-        W !!,"The default threshold cost for the Prosthetic extract is $"_ECTHLD_".00."
-        S DIR(0)="Y",DIR("A")="Would you like to change the threshold?",DIR("B")="NO" D ^DIR K DIR I X["^" S QFLG=1 Q
-        I Y D
-        .W !!,"Cost > threshold"
-        .S DIR(0)="N^0:999999",DIR("A")="Enter the new threshold cost" D ^DIR K DIR S ECTHLD=Y I X["^" S QFLG=1 Q
-        ; get date range from user
-        W !!,"Enter the date range for which you would like to scan the Prosthetic",!,"Extract records.",!
-        S DONE=0 F  S (ECED,ECSD)="" D  Q:QFLG!DONE
-        .K %DT S %DT="AEX",%DT("A")="Starting with Date: ",%DT(0)=-DATE D ^%DT
-        .I Y<0 S QFLG=1 Q
-        .S ECSD=Y,ECSD1=ECSD-.1
-        .D DD^%DT S ECSTART=Y
-        .K %DT S %DT="AEX",%DT("A")="Ending with Date: ",%DT(0)=-DATE D ^%DT
-        .I Y<0 S QFLG=1 Q
-        .I Y<ECSD D  Q
-        ..W !!,"The ending date cannot be earlier than the starting date."
-        ..W !,"Please try again.",!!
-        .I $E(Y,1,5)'=$E(ECSD,1,5) D  Q
-        ..W !!,"Beginning and ending dates must be in the same month and year."
-        ..W !,"Please try again.",!!
-        .S ECED=Y
-        .D DD^%DT S ECEND=Y
-        .S DONE=1
-        Q
-        ;
-PROCESS ; entry point for queued report
-        S ZTREQ="@"
-        S ECXERR=0 D EN^ECXUPRO1 Q:ECXERR
-        S QFLG=0 D PRINT
-        Q
-        ;
-PRINT   ; process temp file and print report
-        N PG,QFLG,GTOT,LN,COUNT,FKEY,COST,SSN,REC,SDAY
-        U IO
-        I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ Q
-        S (PG,QFLG,GTOT)=0,$P(LN,"-",132)=""
-        D HEADER Q:QFLG
-        S COUNT=0,FKEY=""
-        F  S FKEY=$O(^TMP($J,FKEY)) Q:FKEY=""!QFLG  D
-        .S COST="" F  S COST=$O(^TMP($J,FKEY,COST)) Q:COST=""!QFLG  D
-        .. S SDAY="" F  S SDAY=$O(^TMP($J,FKEY,COST,SDAY)) Q:SDAY=""!QFLG  D
-        ...S SSN="" F  S SSN=$O(^TMP($J,FKEY,COST,SDAY,SSN)) Q:SSN=""!QFLG  S REC=^(SSN)  D
-        ....S COUNT=COUNT+1
-        ....I $Y+3>IOSL D HEADER Q:QFLG
-        ....W !,$P(REC,U),?8,$P(REC,U,2),?21,$P(REC,U,3),?39,$P(REC,U,4),?70,$P(REC,U,5),?93,$$RJ^XLFSTR($P(REC,U,6),8),?110,$$RJ^XLFSTR($P(REC,U,7),11)
-        Q:QFLG
-        I COUNT=0 W !!,?8,"No unusual costs to report for this extract"
-CLOSE   ;
-        I $E(IOST)="C",'QFLG D
-        .S SS=22-$Y F JJ=1:1:SS W !
-        .S DIR(0)="E" W ! D ^DIR K DIR
-        Q
-        ;
-HEADER  ;header and page control
-        N SS,JJ
-        I $E(IOST)="C" D
-        .S SS=22-$Y F JJ=1:1:SS W !
-        .I PG>0 S DIR(0)="E" W ! D ^DIR K DIR S:'Y QFLG=1
-        Q:QFLG
-        W:$Y!($E(IOST)="C") @IOF S PG=PG+1
-        W !,"Prosthetic Extract Unusual Cost Report",?124,"Page: "_PG
-        W !,"Start Date: ",ECSTART,?97,"Report Run Date/Time: "_ECRUN
-        W !,"  End Date: ",ECEND,?97,"     Threshold Value: ",ECTHLD
-        W !!,?21,"Date of",?43,"PCE CPT/",?112,"Cost of"
-        W !,"Name",?11,"SSN",?21,"Service",?36,"HCPCS CODE & Modifiers"
-        W ?72,"Feeder Key",?93,"Quantity",?110,"Transaction"
-        W !,LN,!
-        Q
-        ;
+ECXUPRO ;ALB/TJL-Prosthetic Extract Unusual Cost Report ; 7/1/03 1:00pm
+ ;;3.0;DSS EXTRACTS;**49**;July 1, 2003
+ ;
+EN ; entry point
+ N X,Y,DATE,ECRUN,ECXDESC,ECXSAVE,ECXTL,ECTHLD
+ N ECINST,ECSD,ECSD1,ECSTART,ECED,ECEND,ECXERR,QFLG
+ S QFLG=0
+ S ECINST=$$PDIV^ECXPUTL
+ ; get today's date
+ D NOW^%DTC S DATE=X,Y=$E(%,1,12) D DD^%DT S ECRUN=$P(Y,"@") K %DT
+ D BEGIN Q:QFLG
+ D SELECT Q:QFLG
+ S ECXDESC="Prosthetic Extract Unusual Cost Report"
+ S ECXSAVE("EC*")=""
+ W !!,"This report requires 132-column format."
+ D EN^XUTMDEVQ("PROCESS^ECXUPRO",ECXDESC,.ECXSAVE)
+ I POP W !!,"No device selected...exiting.",! Q
+ I IO'=IO(0) D ^%ZISC
+ D HOME^%ZIS
+ D AUDIT^ECXKILL
+ Q
+ ;
+BEGIN ; display report description
+ W @IOF
+ W !,"This report prints a listing of unusual costs that would be"
+ W !,"generated by the Prosthetic extract (PRO) as determined by a"
+ W !,"user-defined threshold value.  It should be run prior to the"
+ W !,"generation of the actual extract(s) to identify and fix, as"
+ W !,"necessary, any costs determined to be erroneous."
+ W !!,"Unusual costs are those where the Cost of Transaction is"
+ W !,"greater than the threshold value."
+ W !!,"Note: The threshold can be set after a report is selected."
+ W !!,"Run times for this report will vary depending upon the size of"
+ W !,"the extract and could take as long as 30 minutes or more to"
+ W !,"complete.  This report has no effect on the actual extracts and"
+ W !,"can be run as needed."
+ W !!,"The report is sorted by Feeder Key, then by descending Cost of"
+ W !,"Transaction and SSN."
+ S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q
+ W:$Y!($E(IOST)="C") @IOF,!!
+ Q
+ ;
+SELECT ; user inputs for threshold cost and date range
+ N DONE,OUT
+ ; allow user to set threshold cost
+ S ECTHLD=500
+ W !!,"The default threshold cost for the Prosthetic extract is $"_ECTHLD_".00."
+ S DIR(0)="Y",DIR("A")="Would you like to change the threshold?",DIR("B")="NO" D ^DIR K DIR I X["^" S QFLG=1 Q
+ I Y D
+ .W !!,"Cost > threshold"
+ .S DIR(0)="N^0:999999",DIR("A")="Enter the new threshold cost" D ^DIR K DIR S ECTHLD=Y I X["^" S QFLG=1 Q
+ ; get date range from user
+ W !!,"Enter the date range for which you would like to scan the Prosthetic",!,"Extract records.",!
+ S DONE=0 F  S (ECED,ECSD)="" D  Q:QFLG!DONE
+ .K %DT S %DT="AEX",%DT("A")="Starting with Date: ",%DT(0)=-DATE D ^%DT
+ .I Y<0 S QFLG=1 Q
+ .S ECSD=Y,ECSD1=ECSD-.1
+ .D DD^%DT S ECSTART=Y
+ .K %DT S %DT="AEX",%DT("A")="Ending with Date: ",%DT(0)=-DATE D ^%DT
+ .I Y<0 S QFLG=1 Q
+ .I Y<ECSD D  Q
+ ..W !!,"The ending date cannot be earlier than the starting date."
+ ..W !,"Please try again.",!!
+ .I $E(Y,1,5)'=$E(ECSD,1,5) D  Q
+ ..W !!,"Beginning and ending dates must be in the same month and year."
+ ..W !,"Please try again.",!!
+ .S ECED=Y
+ .D DD^%DT S ECEND=Y
+ .S DONE=1
+ Q
+ ;
+PROCESS ; entry point for queued report
+ S ZTREQ="@"
+ S ECXERR=0 D EN^ECXUPRO1 Q:ECXERR
+ S QFLG=0 D PRINT
+ Q
+ ;
+PRINT ; process temp file and print report
+ N PG,QFLG,GTOT,LN,COUNT,FKEY,COST,SSN,REC
+ U IO
+ I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ Q
+ S (PG,QFLG,GTOT)=0,$P(LN,"-",132)=""
+ D HEADER Q:QFLG
+ S COUNT=0,FKEY=""
+ F  S FKEY=$O(^TMP($J,FKEY)) Q:FKEY=""!QFLG  D
+ .S COST="" F  S COST=$O(^TMP($J,FKEY,COST)) Q:COST=""!QFLG  D
+ ..S SSN="" F  S SSN=$O(^TMP($J,FKEY,COST,SSN)) Q:SSN=""!QFLG  S REC=^(SSN)  D
+ ...S COUNT=COUNT+1
+ ...I $Y+3>IOSL D HEADER Q:QFLG
+ ...W !,$P(REC,U),?8,$P(REC,U,2),?21,$P(REC,U,3),?39,$P(REC,U,4),?70,$P(REC,U,5),?93,$$RJ^XLFSTR($P(REC,U,6),8),?110,$$RJ^XLFSTR($P(REC,U,7),11)
+ Q:QFLG
+ I COUNT=0 W !!,?8,"No unusual costs to report for this extract"
+CLOSE ;
+ I $E(IOST)="C",'QFLG D
+ .S SS=22-$Y F JJ=1:1:SS W !
+ .S DIR(0)="E" W ! D ^DIR K DIR
+ Q
+ ;
+HEADER ;header and page control
+ N SS,JJ
+ I $E(IOST)="C" D
+ .S SS=22-$Y F JJ=1:1:SS W !
+ .I PG>0 S DIR(0)="E" W ! D ^DIR K DIR S:'Y QFLG=1
+ Q:QFLG
+ W:$Y!($E(IOST)="C") @IOF S PG=PG+1
+ W !,"Prosthetic Extract Unusual Cost Report",?124,"Page: "_PG
+ W !,"Start Date: ",ECSTART,?97,"Report Run Date/Time: "_ECRUN
+ W !,"  End Date: ",ECEND,?97,"     Threshold Value: ",ECTHLD
+ W !!,?21,"Date of",?43,"PCE CPT/",?112,"Cost of"
+ W !,"Name",?11,"SSN",?21,"Service",?36,"HCPCS CODE & Modifiers"
+ W ?72,"Feeder Key",?93,"Quantity",?110,"Transaction"
+ W !,LN,!
+ Q
+ ;

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXUPRO1.m

@@ -1 @@
-ECXUPRO1        ;ALB/TJL-Prosthetics Extract Unusual Cost Report; 01/08/08 2:49pm
-        ;;3.0;DSS EXTRACTS;**49,111**;Jul 2, 2003;Build 4
-        ;
-EN      ; entry point
-        N COUNT,ECDFN,ECD,PROCOST
-        K ^TMP($J)
-        S COUNT=0
-        S ECD=ECSD1,ECED=ECED+.3
-        D GETRECS
-        Q
-        ;
-GETRECS ; get records that are over the threshold
-        N PDA,SUBDA,PROLB,PRO0,PROFORM
-        N DIC,DR,DA,DIQ
-        S QFLG=0,ECXLNE=1,ECXED1=ECED+.9999
-        S PDA=ECSD1
-        F  S PDA=$O(^RMPR(660,"CT",PDA)) Q:(PDA>ECXED1)!('PDA)!(QFLG=1)  D
-        .S SUBDA=0
-        .F  S SUBDA=$O(^RMPR(660,"CT",PDA,SUBDA))  Q:('SUBDA)!(QFLG=1)  D
-        ..Q:'$D(^RMPR(660,SUBDA,0))
-        ..S PRO0=^RMPR(660,SUBDA,0)
-        ..S PROLB=$G(^RMPR(660,SUBDA,"LB"))
-        ..K ECXP S DIC="^RMPR(660,",DR=".02;11",DA=SUBDA,DIQ(0)="EI"
-        ..S DIQ="ECXP" D EN^DIQ1
-        ..S ECXDFN=$G(ECXP(660,SUBDA,.02,"I"))
-        ..S PROFORM=$G(ECXP(660,SUBDA,11,"E"))_U_$G(ECXP(660,SUBDA,11,"I"))
-        ..Q:'$$PATDEM^ECXUTL2(ECXDFN,PDA)
-        ..Q:'$$NTEG^ECXPRO1(ECXDFN,.ECXLNE,SUBDA,PRO0,PROLB,ECINST,PROFORM)
-        ..S PROCOST=$P(PRO0,U,16)
-        ..S:PROFORM["-3" PROCOST=$P(PROLB,U,9)
-        ..S:($P(PROFORM,U,2)=11)!($P(PROFORM,U,2)=12) PROCOST=0
-        ..S:PROCOST="" PROCOST=0
-        ..S PROCOST=(PROCOST+.5)\1
-        ..S:PROCOST>999999 PROCOST=999999
-        ..I PROCOST>ECTHLD D FILE
-        Q
-FILE    ; put records in temp file to print later
-        N OK,PROPAT,PRONAME,PROSSN,CPTCODE,ECXFEKEY,PROQTY
-        S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECD,"."),"1;",.PROPAT)
-        I 'OK Q
-        S PRONAME=PROPAT("NAME")
-        S PROSSN=PROPAT("SSN")
-        S PRODAY=$E(PDA,4,5)_"/"_$E(PDA,6,7)_"/"_$E(PDA,2,3)
-        S CPTCODE=$E(ECXHCPCS,1,5)
-        I PROFORM["-3" F ECXLAB="LAB","ORD" D FEEDINFO^ECXPRO2(ECXSRCE,CPTCODE,ECXTYPE,ECXSTAT2,ECXRQST,ECXRCST,ECXLAB)
-        I PROFORM'["-3" S ECXLAB="NONL" D FEEDINFO^ECXPRO2(ECXSRCE,CPTCODE,ECXTYPE,ECXSTAT2,ECXRQST,ECXRCST,ECXLAB)
-        S PROQTY=$P(PRO0,U,7)
-        S:(+PROQTY=0) PROQTY=1
-        S PROQTY=$$RJ^XLFSTR(PROQTY,8,0)
-        S ^TMP($J,ECXFEKEY,-PROQTY,SUBDA,PROSSN)=PRONAME_U_PROSSN_U_PRODAY_U_ECXHCPCS_U_ECXFEKEY_U_PROQTY_U_"$"_$FNUMBER(PROCOST,",",2)
-        S COUNT=COUNT+1
-        I COUNT#100=0 I $$S^ZTLOAD S (ZSTOP,ECXERR)=1
-        Q
-EXIT    S ECXERR=1 Q
+ECXUPRO1 ;ALB/TJL-Prosthetics Extract Unusual Cost Report; 7/2/03 2:49pm
+ ;;3.0;DSS EXTRACTS;**49**;Jul 2, 2003
+ ;
+EN ; entry point
+ N COUNT,ECDFN,ECD,PROCOST
+ K ^TMP($J)
+ S COUNT=0
+ S ECD=ECSD1,ECED=ECED+.3
+ D GETRECS
+ Q
+ ;
+GETRECS ; get records that are over the threshold
+ N PDA,SUBDA,PROLB,PRO0,PROFORM
+ N DIC,DR,DA,DIQ
+ S QFLG=0,ECXLNE=1,ECXED1=ECED+.9999
+ S PDA=ECSD1
+ F  S PDA=$O(^RMPR(660,"CT",PDA)) Q:(PDA>ECXED1)!('PDA)!(QFLG=1)  D
+ .S SUBDA=0
+ .F  S SUBDA=$O(^RMPR(660,"CT",PDA,SUBDA))  Q:('SUBDA)!(QFLG=1)  D
+ ..Q:'$D(^RMPR(660,SUBDA,0))
+ ..S PRO0=^RMPR(660,SUBDA,0)
+ ..S PROLB=$G(^RMPR(660,SUBDA,"LB"))
+ ..K ECXP S DIC="^RMPR(660,",DR=".02;11",DA=SUBDA,DIQ(0)="EI"
+ ..S DIQ="ECXP" D EN^DIQ1
+ ..S ECXDFN=$G(ECXP(660,SUBDA,.02,"I"))
+ ..S PROFORM=$G(ECXP(660,SUBDA,11,"E"))_U_$G(ECXP(660,SUBDA,11,"I"))
+ ..Q:'$$PATDEM^ECXUTL2(ECXDFN,PDA)
+ ..Q:'$$NTEG^ECXPRO1(ECXDFN,.ECXLNE,SUBDA,PRO0,PROLB,ECINST,PROFORM)
+ ..S PROCOST=$P(PRO0,U,16)
+ ..S:PROFORM["-3" PROCOST=$P(PROLB,U,9)
+ ..S:($P(PROFORM,U,2)=11)!($P(PROFORM,U,2)=12) PROCOST=0
+ ..S:PROCOST="" PROCOST=0
+ ..S PROCOST=(PROCOST+.5)\1
+ ..S:PROCOST>999999 PROCOST=999999
+ ..I PROCOST>ECTHLD D FILE
+ Q
+FILE ; put records in temp file to print later
+ N OK,PROPAT,PRONAME,PROSSN,CPTCODE,ECXFEKEY,PROQTY
+ S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECD,"."),"1;",.PROPAT)
+ I 'OK Q
+ S PRONAME=PROPAT("NAME")
+ S PROSSN=PROPAT("SSN")
+ S PRODAY=$E(PDA,4,5)_"/"_$E(PDA,6,7)_"/"_$E(PDA,2,3)
+ S CPTCODE=$E(ECXHCPCS,1,5)
+ I PROFORM["-3" F ECXLAB="LAB","ORD" D FEEDINFO^ECXPRO2(ECXSRCE,CPTCODE,ECXTYPE,ECXSTAT2,ECXRQST,ECXRCST,ECXLAB)
+ I PROFORM'["-3" S ECXLAB="NONL" D FEEDINFO^ECXPRO2(ECXSRCE,CPTCODE,ECXTYPE,ECXSTAT2,ECXRQST,ECXRCST,ECXLAB)
+ S PROQTY=$P(PRO0,U,7)
+ S:(+PROQTY=0) PROQTY=1
+ S PROQTY=$$RJ^XLFSTR(PROQTY,8,0)
+ S ^TMP($J,ECXFEKEY,-PROQTY,PROSSN)=PRONAME_U_PROSSN_U_PRODAY_U_ECXHCPCS_U_ECXFEKEY_U_PROQTY_U_"$"_$FNUMBER(PROCOST,",",2)
+ S COUNT=COUNT+1
+ I COUNT#100=0 I $$S^ZTLOAD S (ZSTOP,ECXERR)=1
+ Q
+EXIT S ECXERR=1 Q

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXUSUR.m

@@ -1 @@
-ECXUSUR ;ALB/TJL-Surgery Extract Unusual Volume Report ; 9/4/07 8:19am
-        ;;3.0;DSS EXTRACTS;**49,71,84,93,105**;July 1, 2003;Build 70
-        ;
-EN      ; entry point
-        N X,Y,DATE,ECRUN,ECXDESC,ECXSAVE,ECXTL,ECTHLD
-        N ECSD,ECSD1,ECSTART,ECED,ECEND,ECXERR,QFLG,ECXFLAG
-        S QFLG=0,ECTHLD="",ECXFLAG=$G(FLAG)
-        ; get today's date
-        D NOW^%DTC S DATE=X,Y=$E(%,1,12) D DD^%DT S ECRUN=$P(Y,"@") K %DT
-        I 'ECXFLAG D BEGIN Q:QFLG
-        D SELECT Q:QFLG
-        S ECXDESC=$S(ECXFLAG:"SUR Volume Report",1:"Surgery Extract Unusual Volume Report")
-        S ECXSAVE("EC*")=""
-        W !!,"This report requires 132-column format."
-        D EN^XUTMDEVQ("PROCESS^ECXUSUR",ECXDESC,.ECXSAVE)
-        I POP W !!,"No device selected...exiting.",! Q
-        I IO'=IO(0) D ^%ZISC
-        D HOME^%ZIS
-        D AUDIT^ECXKILL
-        Q
-        ;
-BEGIN   ; display report description
-        W @IOF
-        W !,"This report prints a listing of unusual volumes that would be"
-        W !,"generated by the Surgery extract (SUR) as determined by a"
-        W !,"user-defined threshold value.  It should be run prior to the"
-        W !,"generation of the actual extract(s) to identify and fix, as"
-        W !,"necessary, any volumes determined to be erroneous."
-        W !!,"Unusual volumes are those where either the Operation Time,"
-        W !,"Patient Time, Anesthesia Time, Recovery Room Time, OR Clean Time"
-        W !,"or Pt Holding Time field is greater than the threshold value."
-        W !!,"Note: The threshold can be set after a report is selected."
-        W !!,"Run times for this report will vary depending upon the size of"
-        W !,"the extract and could take as long as 30 minutes or more to"
-        W !,"complete.  This report has no effect on the actual extracts and"
-        W !,"can be run as needed."
-        W !!,"The report is sorted by descending Volume and Case Number."
-        S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q
-        W:$Y!($E(IOST)="C") @IOF,!!
-        Q
-        ;
-SELECT  ; user inputs for threshold volume and date range
-        N DONE,OUT
-        ; allow user to set threshold volume
-        I 'ECXFLAG D
-        .S ECTHLD=25
-        .W !!,"The default threshold volume for the Surgery extract is "_ECTHLD_"."
-        .W !,"The default threshold volume ("_ECTHLD_") equates to 6 hours."
-        .S DIR(0)="Y",DIR("A")="Would you like to change the threshold?",DIR("B")="NO" D ^DIR K DIR I X["^" S QFLG=1 Q
-        .I Y D
-        ..W !!,"Volume > threshold"
-        ..S DIR(0)="N^0:99",DIR("A")="Enter the new threshold volume" D ^DIR K DIR S ECTHLD=Y I X["^" S QFLG=1 Q
-        ; get date range from user
-        Q:QFLG
-        W !!,"Enter the date range for which you would like to scan the"
-        W !,"Surgery Extract records.",!
-        S DONE=0 F  S (ECED,ECSD)="" D  Q:QFLG!DONE
-        .K %DT S %DT="AEX",%DT("A")="Starting with Date: ",%DT(0)=-DATE D ^%DT
-        .I Y<0 S QFLG=1 Q
-        .S ECSD=Y,ECSD1=ECSD-.1
-        .D DD^%DT S ECSTART=Y
-        .K %DT S %DT="AEX",%DT("A")="Ending with Date: ",%DT(0)=-DATE D ^%DT
-        .I Y<0 S QFLG=1 Q
-        .I Y<ECSD D  Q
-        ..W !!,"The ending date cannot be earlier than the starting date."
-        ..W !,"Please try again.",!!
-        .I $E(Y,1,5)'=$E(ECSD,1,5) D  Q
-        ..W !!,"Beginning and ending dates must be in the same month and year"
-        ..W !,"Please try again.",!!
-        .S ECED=Y
-        .D DD^%DT S ECEND=Y
-        .S DONE=1
-        Q
-        ;
-PROCESS ; entry point for queued report
-        S ZTREQ="@"
-        S ECXERR=0 D EN^ECXUSUR1 Q:ECXERR
-        S QFLG=0 D PRINT
-        Q
-        ;
-PRINT   ; process temp file and print report
-        N PG,QFLG,GTOT,LN,COUNT,VOL,SUB,REC
-        U IO
-        I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ Q
-        S (PG,QFLG,GTOT,COUNT)=0,$P(LN,"-",132)=""
-        D HEADER Q:QFLG
-        S VOL=-999999 F  S VOL=$O(^TMP($J,VOL)) Q:VOL=""!QFLG  D
-        .S SUB="" F  S SUB=$O(^TMP($J,VOL,SUB)) Q:SUB=""!QFLG  S REC=^(SUB)  D
-        ..S COUNT=COUNT+1
-        ..I $Y+3>IOSL D HEADER Q:QFLG
-        ..W !,?1,$P(REC,U),?7,$P(REC,U,2),?18,$P(REC,U,3),?27,$P(REC,U,4)
-        ..W ?34,$P(REC,U,5),?55,$$RJ^XLFSTR($P(REC,U,7),4)
-        ..W ?66,$$RJ^XLFSTR($P(REC,U,11),4),?77,$$RJ^XLFSTR($P(REC,U,9),4)
-        ..W ?86,$$RJ^XLFSTR($P(REC,U,10),4),?93,$$RJ^XLFSTR($P(REC,U,6),4)
-        ..W ?103,$$RJ^XLFSTR($P(REC,U,8),4),?113,$P(REC,U,14)
-        ..W ?117,$P(REC,U,13)
-        Q:QFLG
-        I COUNT=0 W !!,?8,$S(ECXFLAG=1:"No surgery volumes to report for this extract",1:"No unusual volumes to report for this extract")
-CLOSE   ;
-        I $E(IOST)="C",'QFLG D
-        .S SS=22-$Y F JJ=1:1:SS W !
-        .S DIR(0)="E" W ! D ^DIR K DIR
-        Q
-        ;
-HEADER  ;header and page control
-        N SS,JJ
-        I $E(IOST)="C" D
-        .S SS=22-$Y F JJ=1:1:SS W !
-        .I PG>0 S DIR(0)="E" W ! D ^DIR K DIR S:'Y QFLG=1
-        Q:QFLG
-        W:$Y!($E(IOST)="C") @IOF S PG=PG+1
-        W !,$S(ECXFLAG:"SUR Volume Report",1:"Surgery Extract Unusual Volume Report"),?124,"Page: "_PG
-        W !,"Start Date: ",ECSTART,?97,"Report Run Date/Time: "_ECRUN
-        W !,"  End Date: ",ECEND I 'ECXFLAG W ?97,"     Threshold Value: ",ECTHLD
-        W !!,?28,"Case",?38,"Encounter",?52,"Pt Holding",?63,"Anesthesia",?75,"Patient",?83,"Operation",?93,"PACU",?101,"OR Clean",?111,"Canc/",?121,"Principal"
-        W !,?1,"Name",?10,"SSN",?20,"Day",?27,"Number",?40,"Number"
-        W ?54,"Time",?66,"Time",?77,"Time",?86,"Time",?93,"Time",?103,"Time"
-        W ?111,"Abort",?121,"Procedure"
-        W !,LN,!
-        Q
-        ;
+ECXUSUR ;ALB/TJL-Surgery Extract Unusual Volume Report ; 4/11/06 10:44AM
+ ;;3.0;DSS EXTRACTS;**49,71,84,93**;July 1, 2003
+ ;
+EN ; entry point
+ N X,Y,DATE,ECRUN,ECXDESC,ECXSAVE,ECXTL,ECTHLD
+ N ECSD,ECSD1,ECSTART,ECED,ECEND,ECXERR,QFLG,ECXFLAG
+ S QFLG=0,ECTHLD="",ECXFLAG=$G(FLAG)
+ ; get today's date
+ D NOW^%DTC S DATE=X,Y=$E(%,1,12) D DD^%DT S ECRUN=$P(Y,"@") K %DT
+ I 'ECXFLAG D BEGIN Q:QFLG
+ D SELECT Q:QFLG
+ S ECXDESC=$S(ECXFLAG:"SUR Volume Report",1:"Surgery Extract Unusual Volume Report")
+ S ECXSAVE("EC*")=""
+ W !!,"This report requires 132-column format."
+ D EN^XUTMDEVQ("PROCESS^ECXUSUR",ECXDESC,.ECXSAVE)
+ I POP W !!,"No device selected...exiting.",! Q
+ I IO'=IO(0) D ^%ZISC
+ D HOME^%ZIS
+ D AUDIT^ECXKILL
+ Q
+ ;
+BEGIN ; display report description
+ W @IOF
+ W !,"This report prints a listing of unusual volumes that would be"
+ W !,"generated by the Surgery extract (SUR) as determined by a"
+ W !,"user-defined threshold value.  It should be run prior to the"
+ W !,"generation of the actual extract(s) to identify and fix, as"
+ W !,"necessary, any volumes determined to be erroneous."
+ W !!,"Unusual volumes are those where either the Operation Time,"
+ W !,"Patient Time, Anesthesia Time, Recovery Room Time, OR Clean Time"
+ W !,"or Pt Holding Time field is greater than the threshold value."
+ W !!,"Note: The threshold can be set after a report is selected."
+ W !!,"Run times for this report will vary depending upon the size of"
+ W !,"the extract and could take as long as 30 minutes or more to"
+ W !,"complete.  This report has no effect on the actual extracts and"
+ W !,"can be run as needed."
+ W !!,"The report is sorted by descending Volume and Case Number."
+ S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q
+ W:$Y!($E(IOST)="C") @IOF,!!
+ Q
+ ;
+SELECT ; user inputs for threshold volume and date range
+ N DONE,OUT
+ ; allow user to set threshold volume
+ I 'ECXFLAG D
+ .S ECTHLD=25
+ .W !!,"The default threshold volume for the Surgery extract is "_ECTHLD_"."
+ .W !,"The default threshold volume ("_ECTHLD_") equates to 6 hours."
+ .S DIR(0)="Y",DIR("A")="Would you like to change the threshold?",DIR("B")="NO" D ^DIR K DIR I X["^" S QFLG=1 Q
+ .I Y D
+ ..W !!,"Volume > threshold"
+ ..S DIR(0)="N^0:99",DIR("A")="Enter the new threshold volume" D ^DIR K DIR S ECTHLD=Y I X["^" S QFLG=1 Q
+ ; get date range from user
+ Q:QFLG
+ W !!,"Enter the date range for which you would like to scan the"
+ W !,"Surgery Extract records.",!
+ S DONE=0 F  S (ECED,ECSD)="" D  Q:QFLG!DONE
+ .K %DT S %DT="AEX",%DT("A")="Starting with Date: ",%DT(0)=-DATE D ^%DT
+ .I Y<0 S QFLG=1 Q
+ .S ECSD=Y,ECSD1=ECSD-.1
+ .D DD^%DT S ECSTART=Y
+ .K %DT S %DT="AEX",%DT("A")="Ending with Date: ",%DT(0)=-DATE D ^%DT
+ .I Y<0 S QFLG=1 Q
+ .I Y<ECSD D  Q
+ ..W !!,"The ending date cannot be earlier than the starting date."
+ ..W !,"Please try again.",!!
+ .I $E(Y,1,5)'=$E(ECSD,1,5) D  Q
+ ..W !!,"Beginning and ending dates must be in the same month and year"
+ ..W !,"Please try again.",!!
+ .S ECED=Y
+ .D DD^%DT S ECEND=Y
+ .S DONE=1
+ Q
+ ;
+PROCESS ; entry point for queued report
+ S ZTREQ="@"
+ S ECXERR=0 D EN^ECXUSUR1 Q:ECXERR
+ S QFLG=0 D PRINT
+ Q
+ ;
+PRINT ; process temp file and print report
+ N PG,QFLG,GTOT,LN,COUNT,VOL,SUB,REC
+ U IO
+ I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ Q
+ S (PG,QFLG,GTOT,COUNT)=0,$P(LN,"-",132)=""
+ D HEADER Q:QFLG
+ S VOL=-999999 F  S VOL=$O(^TMP($J,VOL)) Q:VOL=""!QFLG  D
+ .S SUB="" F  S SUB=$O(^TMP($J,VOL,SUB)) Q:SUB=""!QFLG  S REC=^(SUB)  D
+ ..S COUNT=COUNT+1
+ ..I $Y+3>IOSL D HEADER Q:QFLG
+ ..W !,$P(REC,U),?6,$P(REC,U,2),?17,$P(REC,U,3),?26,$P(REC,U,4)
+ ..W ?33,$P(REC,U,5),?55,$$RJ^XLFSTR($P(REC,U,9),4)
+ ..W ?63,$$RJ^XLFSTR($P(REC,U,10),4),?74,$$RJ^XLFSTR($P(REC,U,11),4)
+ ..W ?83,$$RJ^XLFSTR($P(REC,U,6),4),?90,$$RJ^XLFSTR($P(REC,U,8),4)
+ ..W ?101,$$RJ^XLFSTR($P(REC,U,7),4),?114,$P(REC,U,13)
+ Q:QFLG
+ I COUNT=0 W !!,?8,$S(ECXFLAG=1:"No surgery volumes to report for this extract",1:"No unusual volumes to report for this extract")
+CLOSE ;
+ I $E(IOST)="C",'QFLG D
+ .S SS=22-$Y F JJ=1:1:SS W !
+ .S DIR(0)="E" W ! D ^DIR K DIR
+ Q
+ ;
+HEADER ;header and page control
+ N SS,JJ
+ I $E(IOST)="C" D
+ .S SS=22-$Y F JJ=1:1:SS W !
+ .I PG>0 S DIR(0)="E" W ! D ^DIR K DIR S:'Y QFLG=1
+ Q:QFLG
+ W:$Y!($E(IOST)="C") @IOF S PG=PG+1
+ W !,$S(ECXFLAG:"SUR Volume Report",1:"Surgery Extract Unusual Volume Report"),?124,"Page: "_PG
+ W !,"Start Date: ",ECSTART,?97,"Report Run Date/Time: "_ECRUN
+ W !,"  End Date: ",ECEND I 'ECXFLAG W ?97,"     Threshold Value: ",ECTHLD
+ W !!,?27,"Case",?37,"Encounter",?53,"Patient",?61,"Operation",?71,"Anesthesia",?83,"PACU",?89,"OR Clean",?99,"Pt Holding",?114,"Principal"
+ W !,"Name",?9,"SSN",?19,"Day",?26,"Number",?39,"Number"
+ W ?55,"Time",?63,"Time",?74,"Time",?83,"Time",?90,"Time",?101,"Time"
+ W ?114,"Procedure"
+ W !,LN,!
+ Q
+ ;

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXUSUR1.m

@@ -1 @@
-ECXUSUR1        ;ALB/TJL-Surgery Extract Unusual Volume Report ; 1/8/08 9:58am
-        ;;3.0;DSS EXTRACTS;**49,71,105,111**;July 1, 2003;Build 4
-EN      ;
-        N ECHEAD,COUNT,TIMEDIF,ECXPROC
-        S ECHEAD="SUR"
-        S (COUNT,QFLG)=0,ECED=ECED+.3,ECD=ECSD1
-        F  S ECD=$O(^SRF("AC",ECD)) Q:('ECD)!(ECD>ECED)!(QFLG)  D
-        .S ECD0=0
-        .F  S ECD0=$O(^SRF("AC",ECD,ECD0)) Q:'ECD0  D
-        ..I $D(^SRF(ECD0,0)) S ECXDFN=+$P(^(0),U,1) D STUFF Q:QFLG
-        Q
-        ;
-STUFF   ;gather data
-        N J,DATA1,DATA2,DATAOP,ECXNONL,ECXSTOP
-        S ECXDATE=ECD,ECXERR=0,ECXQ=""
-        Q:'$$PATDEM^ECXUTL2(ECXDFN,ECXDATE,"1;2;3;5;")
-        S EC0=^SRF(ECD0,0)
-        S DATA1=$S($D(^SRF(ECD0,.1)):^(.1),1:"")
-        S DATA2=$S($D(^SRF(ECD0,.2)):^(.2),1:"")
-        S DATAOP=$S($D(^SRF(ECD0,"OP")):^("OP"),1:"")
-        S DATAPA=$S($D(^SRF(ECD0,1.1)):^(1.1),1:"")
-        S ECNO=$G(^SRF(ECD0,"NON"))
-        ;get data
-        S ECSS=$P($G(^SRO(137.45,+$P(EC0,U,4),0)),U,2)
-        S ECSS=$$RJ^XLFSTR($P($G(^DIC(45.3,+ECSS,0)),U),3,0)
-        S:ECSS="000" ECSS="999"
-        ;look for non-OR
-        S (ECNT,ECNL,ECXNONL,ECXSTOP)=""
-        I $P(ECNO,U)="Y" D
-        .S A1=$P(ECNO,U,5)
-        .S A2=$P(ECNO,U,4)
-        .S TIME="##"
-        .D:(A1&A2) TIME S ECNT=TIME
-        .S ECXNONL=+$P(ECNO,U,2)
-        .S ECNL=$P($G(^ECX(728.44,ECXNONL,0)),U,9)
-        .I ECNL="" S ECNL="UNKNOWN"
-        .;
-        .; Get DSS Stop Code to use in encounter number
-        .S ECXSTOP=$P($G(^ECX(728.44,ECXNONL,0)),U,4)
-        ;
-        ;retrieving anesthesia times first, then operation and patient
-        ;times, then storing in following order:
-        ;ecode0="recovery room time^pt hold area time^or clean time^patient
-        ;time^operation time^anesthesia time
-        S ECODE0=""
-        F J="1,4","2,3","10,12","13,14","15,10" D
-        .S A2=$P(DATA2,U,$P(J,","))
-        .S A1=$P(DATA2,U,$P(J,",",2))
-        .S TIME="##"
-        .I (A1&A2) D TIMEDIF(A1,A2) D
-        ..I +J'=2 D TIME
-        ..I +J=2 D  ;-Operation Time
-        ...S TIME=$TR($J(TIMEDIF,4,0)," ")
-        ...;I TIME<0 S TIME="###"
-        .S ECODE0=TIME_U_ECODE0 K TIME
-        ;
-        ;retrieve recovery room (PACU) time
-        S A2=$P($G(DATAPA),U,7)
-        S A1=$P($G(DATAPA),U,8)
-        S TIME="##"
-        I (A1&A2) D TIME
-        S ECODE0=TIME_U_ECODE0 K TIME
-        ;
-        I ECNL]"" S $P(ECODE0,U,2)=ECNT
-        ;
-        ;- Was surgery cancelled/aborted
-        S ECCAN=$P($G(^SRF(ECD0,30)),U)
-        I +ECCAN S ECCAN=$$CANC^ECXUTL4(ECNL,$P(DATA2,U,10))
-        ;
-        I ECXFLAG D FILE  Q
-        N PIECE,FILE
-        S FILE="NO"
-        F PIECE=1,2,3,4,5,6 D
-        . I $P(ECODE0,U,PIECE)>ECTHLD S FILE="YES"
-        . I $P(ECODE0,U,PIECE)<0 S FILE="YES"
-        ;
-        I FILE="YES" D FILE Q:ECXERR
-        Q
-        ;
-FILE    ; Store unusual records for display later
-        N OK,SURPAT,SURNAME,SURSSN,SURDT,VOL
-        S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECD,"."),"1;",.SURPAT)
-        I 'OK Q
-        S SURNAME=SURPAT("NAME")
-        S SURSSN=SURPAT("SSN")
-        S SURDT=$E(ECXDATE,4,5)_"/"_$E(ECXDATE,6,7)_"/"_$E(ECXDATE,2,3)
-        ;
-        ; Observation Patient Indicator (yes/no)
-        S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECNL)
-        ;
-        ; Principal Procedure
-        S ECXPROC=$E($P(DATAOP,U),1,15)
-        ;
-        ; If no encounter number don't file record
-        S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXSTOP,ECSS) Q:ECXENC=""
-        ;
-        S VOL=$P(ECODE0,U)
-        I $P(ECODE0,U,2)>VOL S VOL=$P(ECODE0,U,2)
-        I $P(ECODE0,U,3)>VOL S VOL=$P(ECODE0,U,3)
-        S ^TMP($J,-VOL,-ECD0)=SURNAME_U_SURSSN_U_SURDT_U_ECD0_U_ECXENC_U_ECODE0_U_ECXPROC_U_ECCAN
-        S COUNT=COUNT+1
-        I COUNT#100=0 I $$S^ZTLOAD S (ZSTOP,ECXERR)=1
-        Q
-        ;
-TIME    ; given date/time get increment
-        N CON
-        S CON=$P($G(^SRF(ECD0,"CON")),U)
-        D TIMEDIF(A1,A2)
-        I 'CON D
-        .S TIME=$J($TR($J(TIMEDIF,4,0)," "),2,1)
-        .S:TIME>"99.0" TIME="99.0"
-        I CON D
-        .S TIME=$J(($TR($J(TIMEDIF,4,0)," ")/2),2,1)
-        .S:TIME>"99.5" TIME="99.5"
-        ;S:TIME<0 TIME="###"
-        Q
-        ;
-TIMEDIF(START,FINISH)   ; Set values to be compared, in seconds
-        ;
-        S TIMEDIF=$$FMDIFF^XLFDT(START,FINISH,2)/900
-        I (TIMEDIF>0)&(TIMEDIF<.5) S TIMEDIF=.5
-        Q
-        ;
-EXIT    S ECXERR=1 Q
+ECXUSUR1 ;ALB/TJL-Surgery Extract Unusual Volume Report ; 12/1/04 4:48pm
+ ;;3.0;DSS EXTRACTS;**49,71**;July 1, 2003
+EN ;
+ N ECHEAD,COUNT,TIMEDIF,ECXPROC
+ S ECHEAD="SUR"
+ S (COUNT,QFLG)=0,ECED=ECED+.3,ECD=ECSD1
+ F  S ECD=$O(^SRF("AC",ECD)) Q:('ECD)!(ECD>ECED)!(QFLG)  D
+ .S ECD0=0
+ .F  S ECD0=$O(^SRF("AC",ECD,ECD0)) Q:'ECD0  D
+ ..I $D(^SRF(ECD0,0)) S ECXDFN=+$P(^(0),U,1) D STUFF Q:QFLG
+ Q
+ ;
+STUFF ;gather data
+ N J,DATA1,DATA2,DATAOP,ECXNONL,ECXSTOP
+ S ECXDATE=ECD,ECXERR=0,ECXQ=""
+ Q:'$$PATDEM^ECXUTL2(ECXDFN,ECXDATE,"1;2;3;5;")
+ S EC0=^SRF(ECD0,0)
+ S DATA1=$S($D(^SRF(ECD0,.1)):^(.1),1:"")
+ S DATA2=$S($D(^SRF(ECD0,.2)):^(.2),1:"")
+ S DATAOP=$S($D(^SRF(ECD0,"OP")):^("OP"),1:"")
+ S DATAPA=$S($D(^SRF(ECD0,1.1)):^(1.1),1:"")
+ S ECNO=$G(^SRF(ECD0,"NON"))
+ ;get data
+ S ECSS=$P($G(^SRO(137.45,+$P(EC0,U,4),0)),U,2)
+ S ECSS=$$RJ^XLFSTR($P($G(^DIC(45.3,+ECSS,0)),U),3,0)
+ S:ECSS="000" ECSS="999"
+ ;look for non-OR
+ S (ECNT,ECNL,ECXNONL,ECXSTOP)=""
+ I $P(ECNO,U)="Y" D
+ .S A1=$P(ECNO,U,5)
+ .S A2=$P(ECNO,U,4)
+ .S TIME="##"
+ .D:(A1&A2) TIME S ECNT=TIME
+ .S ECXNONL=+$P(ECNO,U,2)
+ .S ECNL=$P($G(^ECX(728.44,ECXNONL,0)),U,9)
+ .I ECNL="" S ECNL="UNKNOWN"
+ .;
+ .; Get DSS Stop Code to use in encounter number
+ .S ECXSTOP=$P($G(^ECX(728.44,ECXNONL,0)),U,4)
+ ;
+ ;retrieving anesthesia times first, then operation and patient
+ ;times, then storing in following order:
+ ;ecode0="recovery room time^pt hold area time^or clean time^patient
+ ;time^operation time^anesthesia time
+ S ECODE0=""
+ F J="1,4","2,3","10,12","13,14","15,10" D
+ .S A2=$P(DATA2,U,$P(J,","))
+ .S A1=$P(DATA2,U,$P(J,",",2))
+ .S TIME="##"
+ .I (A1&A2) D TIMEDIF(A1,A2) D
+ ..I +J'=2 D TIME
+ ..I +J=2 D  ;-Operation Time
+ ...S TIME=$TR($J(TIMEDIF,4,0)," ")
+ ...;I TIME<0 S TIME="###"
+ .S ECODE0=TIME_U_ECODE0 K TIME
+ ;
+ ;retrieve recovery room (PACU) time
+ S A2=$P($G(DATAPA),U,7)
+ S A1=$P($G(DATAPA),U,8)
+ S TIME="##"
+ I (A1&A2) D TIME
+ S ECODE0=TIME_U_ECODE0 K TIME
+ ;
+ I ECNL]"" S $P(ECODE0,U,5)=ECNT
+ ;
+ I ECXFLAG D FILE  Q
+ N PIECE,FILE
+ S FILE="NO"
+ F PIECE=1,2,3,4,5,6 D
+ . I $P(ECODE0,U,PIECE)>ECTHLD S FILE="YES"
+ . I $P(ECODE0,U,PIECE)<0 S FILE="YES"
+ I FILE="YES" D FILE Q:ECXERR
+ Q
+ ;
+FILE ; Store unusual records for display later
+ N OK,SURPAT,SURNAME,SURSSN,SURDT,VOL
+ S OK=$$PAT^ECXUTL3(ECXDFN,$P(ECD,"."),"1;",.SURPAT)
+ I 'OK Q
+ S SURNAME=SURPAT("NAME")
+ S SURSSN=SURPAT("SSN")
+ S SURDT=$E(ECXDATE,4,5)_"/"_$E(ECXDATE,6,7)_"/"_$E(ECXDATE,2,3)
+ ;
+ ; Observation Patient Indicator (yes/no)
+ S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECNL)
+ ;
+ ; Principal Procedure
+ S ECXPROC=$E($P(DATAOP,U),1,15)
+ ;
+ ; If no encounter number don't file record
+ S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXSTOP,ECSS) Q:ECXENC=""
+ ;
+ S VOL=$P(ECODE0,U,4)
+ I $P(ECODE0,U,5)>VOL S VOL=$P(ECODE0,U,5)
+ I $P(ECODE0,U,6)>VOL S VOL=$P(ECODE0,U,6)
+ S ^TMP($J,-VOL,-ECD0)=SURNAME_U_SURSSN_U_SURDT_U_ECD0_U_ECXENC_U_ECODE0_U_ECXPROC
+ S COUNT=COUNT+1
+ I COUNT#100=0 I $$S^ZTLOAD S (ZSTOP,ECXERR)=1
+ Q
+ ;
+TIME ; given date/time get increment
+ N CON
+ S CON=$P($G(^SRF(ECD0,"CON")),U)
+ D TIMEDIF(A1,A2)
+ I 'CON D
+ .S TIME=$J($TR($J(TIMEDIF,4,0)," "),2,1)
+ .S:TIME>"99.0" TIME="99.0"
+ I CON D
+ .S TIME=$J(($TR($J(TIMEDIF,4,0)," ")/2),2,1)
+ .S:TIME>"99.5" TIME="99.5"
+ ;S:TIME<0 TIME="###"
+ Q
+ ;
+TIMEDIF(START,FINISH) ; Set values to be compared, in seconds
+ ;
+ S TIMEDIF=$$FMDIFF^XLFDT(START,FINISH,2)/900
+ I (TIMEDIF>0)&(TIMEDIF<.5) S TIMEDIF=.5
+ Q
+ ;
+EXIT S ECXERR=1 Q

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXUTL2.m

@@ -1 @@
-ECXUTL2 ;ALB/JAP - Utilities for DSS Extracts (cont.) ; 6/12/07 6:38am
-        ;;3.0;DSS EXTRACTS;**8,13,23,24,33,35,39,46,71,84,92,105**;Dec 22, 1997;Build 70
-        ;
-ECXDEF(ECXHEAD,ECXPACK,ECXGRP,ECXFILE,ECXRTN,ECXPIECE,ECXVER)   ;variables specific to extract from file #727.1
-        ;   input 
-        ;   ECXHEAD = extract header code
-        ;   all other formal list parameters passed by reference
-        ;   output
-        ;   ECXPACK = type field (#7)
-        ;   ECXGRP  = group field (#9)
-        ;   ECXFILE = file number field (#1)
-        ;   ECXRTN  = routine field (#4)
-        ;   ECXPIECE= running piece field (#11)
-        ;   ECXVER  = dss version
-        N ECXIEN,ECXARR,DIC,DA,DR,DIQ
-        S (ECXPACK,ECXGRP,ECXFILE,ECXRTN,ECXPIECE,ECXVER)="",ECXIEN=0
-        S ECXIEN=+$O(^ECX(727.1,"C",ECXHEAD,ECXIEN))
-        I ECXIEN=0 D  Q
-        .D MES^XPDUTL(" ")
-        .D MES^XPDUTL(" It appears that you may have a problem with File #727.1 --")
-        .D MES^XPDUTL(" ")
-        .D MES^XPDUTL(" The "_ECHEAD_" Extract is not properly defined.")
-        .D MES^XPDUTL(" ")
-        .D MES^XPDUTL(" Contact National VISTA Support for further assistance.")
-        .D MES^XPDUTL(" ")
-        .I $E(IOST)="C" D
-        ..S SS=22-$Y F JJ=1:1:SS W !
-        ..S DIR(0)="E" W ! D ^DIR K DIR
-        .W !!
-        S DIC="^ECX(727.1,",DA=ECXIEN,DR=".01;1;4;7;9;11",DIQ="ECXARR"
-        D EN^DIQ1
-        S ECXPACK=ECXARR(727.1,ECXIEN,7)
-        ;if this is an inactive extract type, skip it
-        I ECXPACK["Inactive" D  Q
-        .D MES^XPDUTL(" ")
-        .D MES^XPDUTL(" The "_ECHEAD_" Extract is no longer active/valid.")
-        .D MES^XPDUTL(" ")
-        .D MES^XPDUTL(" Contact National VISTA Support for further assistance.")
-        .D MES^XPDUTL(" ")
-        .I $E(IOST)="C" D
-        ..S SS=22-$Y F JJ=1:1:SS W !
-        ..S DIR(0)="E" W ! D ^DIR K DIR
-        .W !!
-        S ECXGRP=ECXARR(727.1,ECXIEN,9)
-        S ECXFILE=ECXARR(727.1,ECXIEN,1)
-        S ECXRTN="START^"_ECXARR(727.1,ECXIEN,4)
-        S ECXPIECE=ECXARR(727.1,ECXIEN,11)
-        ;version of dss/tsi in Austin as specified by btso
-        S ECXVER=7
-        Q
-PATDEM(DFN,DT1,PAR,FLG) ; determine patient information
-        ;  DFN   =
-        ;  DT    =
-        ;  PAR   =
-        ;  FLG   =
-        N DT2,PAT,OK,X
-        D KPATDEM
-        S FLG=$G(FLG),PAR=$S($D(PAR):PAR,1:"1;2;3;4;5;"),DT2=$P(DT1,".")
-        Q:'$$PAT^ECXUTL3(DFN,DT2,PAR,.PAT) 0
-        S ECXMPI=PAT("MPI")
-        I PAR["1" D
-        .S ECXSSN=PAT("SSN"),ECXPNM=PAT("NAME"),ECXDOB=PAT("DOB")
-        .S ECXSEX=PAT("SEX"),ECXREL=PAT("RELIGION"),ECXRACE=PAT("RACE")
-        .S ECXMAR=PAT("MARITAL")
-        .S ECXETH=PAT("ETHNIC"),ECXRC1=PAT("RACE1")
-        I PAR["2" D
-        .S ECXCNTY=PAT("COUNTY"),ECXSTATE=PAT("STATE"),ECXZIP=PAT("ZIP")
-        I PAR["3" D
-        .S ECXPOS=PAT("POS"),ECSC=PAT("SC STAT"),ECXSVC=PAT("SC%")
-        .S ECXVET=PAT("VET"),ECXMEAN=PAT("MEANS"),ECXELIG=PAT("ELIG")
-        .S ECXENRL=PAT("ENROLL LOC")
-        .S ECXERI=PAT("ERI")
-        I PAR["4" S ECXEMP=PAT("EMPLOY")
-        I PAR["5" D
-        .S ECXVIET=PAT("VIETNAM"),ECXAST=PAT("AO STAT"),ECXRST=PAT("IR STAT")
-        .S ECXEST=PAT("EC STAT"),ECXPST=PAT("POW STAT"),ECXPLOC=PAT("POW LOC")
-        .S ECXPHI=PAT("PHI"),ECXMST=PAT("MST STAT"),ECXAOL=PAT("AOL")
-        .S ECXOEF=PAT("ECXOEF"),ECXOEFDT=PAT("ECXOEFDT")
-        I PAR["6" D
-        .S (ECXPAYOR,ECXSAI)="" D VISN19(DFN,.ECXPAYOR,.ECXSAI)
-        I FLG'[3 D
-        .S X=$$PRIMARY(DFN,DT2),ECPTTM=$P(X,U),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3)
-        .S ECPTNPI=$P(X,U,4),ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6)
-        .S ECASNPI=$P(X,U,7)
-        I FLG'[2 D
-        .S ECXINP=$$INP^ECXUTL2(DFN,DT1),ECXA=$P(ECXINP,U),ECXMN=$P(ECXINP,U,2)
-        .S ECXTS=$P(ECXINP,U,3),ECXDOM=$P(ECXINP,U,10),ECXADMDT=$P(ECXINP,U,4)
-        I FLG'[1 S X=$$ENROLLM(DFN)
-        Q 1
-        ;
-KPATDEM ;
-        K ECXADMDT,ECAO,ECASNPI,ECASPR,ECCLAS,ECCLAS2,ECENV,ECPTNPI,ECPTPR,ECPTTM
-        K ECRE,ECSC,ECXA,ECXAST,ECXCAT,ECXCNTY,ECXEST,ECXENRL,ECXDOB
-        K ECXDOM,ECXELIG,ECXINP,ECXMPI,ECXMN,ECXNM,ECXPHI,ECXPLOC,ECXMEAN,ECXMST
-        K ECXPAYOR,ECXPNM,ECXPOS,ECXPRIOR,ECXPST,ECXRACE,ECXREL,ECXRST,ECXSAI
-        K ECXSEX,ECXSSN,ECXSTAT,ECXSTATE,ECXSVC,ECXTS,ECXVIET,ECXZIP,VA,VAERR
-        K ECXSBGRP
-        Q
-ENROLLM(DFN,RNDT)       ;determines enrollment status, category, priority
-        ;and user enrollee status
-        ; input
-        ;    DFN      = IEN from Patient file (Required)
-        ;    RNDT     = Extract Run Date
-        ; output
-        ;    ECXSTAT  = Enrollment status
-        ;    ECXPRIOR = Enrollment priority
-        ;    ECXCAT   = Enrollment priority
-        ;    ECXSBGRP = Enrollment subgroup
-        ;    ECXUESTA = User enrollee
-        ;    return value 0 if no data found, 1 if data found
-        N CAT,PRIOR,STAT,X,X1,X2,X3,ENRIEN,ENR,FL,SBGRP
-        S (ECXCAT,ECXPRIOR,ECXSTAT,ECXSBGRP,ECXEUSTA)=""
-        I $G(DFN)="" Q 0
-        ;User enrollee status, if current or future date set to 'U'
-        ;DBIA #3989
-        S ECXUESTA=$S($$UESTAT^EASUER(DFN):"U",1:"")
-        ;Patient type
-        S ECXPTYPE=$$TYPE^ECXUTL5(DFN)
-        ;Combat Veteran Status DBIA #4156
-        S X3=$$CVEDT^ECXUTL5(DFN,$S($G(ECD):ECD,$G(ECXDATE):ECXDATE,1:DT))
-        ;enrollment priority DBIA
-        S STAT=$$STATUS^DGENA(DFN),PRIOR=$$PRIORITY^DGENA(DFN)
-        S CAT=$$CATEGORY^DGENA4(DFN,STAT),SBGRP=$$ENRSBGRP^DGENA4(DFN)
-        ;find current enrollment when status=2 or 19
-        I "^2^19^"[("^"_STAT_"^") S ECXSTAT=STAT,ECXPRIOR=PRIOR,ECXCAT=CAT,ECXSBGRP=$S(SBGRP=1:"a",SBGRP=3:"c",SBGRP=5:"e",SBGRP=7:"g",1:"") Q 1
-        ;find previous enrollment
-        S ENRIEN=$$FINDCUR^DGENA(DFN) I ENRIEN="" Q 0
-        I $G(RNDT)="" D NOW^%DTC S RNDT=X
-        S RNDT=($E(RNDT,1,3)-1)_$E(RNDT,4,7),FL=0
-        F  S ENRIEN=$$FINDPRI^DGENA(ENRIEN) Q:'ENRIEN  D  Q:FL
-        . S ENR=$$GET^DGENA(ENRIEN,.ENR)
-        . I "^2^19^"[("^"_ENR("STATUS")_"^"),ENR("EFFDATE")>RNDT D
-        . . S ECXSTAT=ENR("STATUS"),ECXPRIOR=PRIOR,FL=1
-        . . S ECXCAT=$$CATEGORY^DGENA4(DFN,ECXSTAT)
-        . . S ECXSBGRP=$$ENRSBGRP^DGENA4(DFN)
-        . . S ECXSBGRP=$S(SBGRP=1:"a",SBGRP=3:"c",SBGRP=5:"e",SBGRP=7:"g",1:"")
-        I FL Q 1
-        ;no enrollment status found =2 or 19
-        S ECXSTAT=STAT,ECXPRIOR=PRIOR,ECXCAT=CAT,ECXSBGRP=$S(SBGRP=1:"a",SBGRP=3:"c",SBGRP=5:"e",SBGRP=7:"g",1:"")
-        Q 1
-PRIMARY(ECXDFN,ECXDATE,ECXPREFX)        ;determine patient's pc team and pc provider
-        ; input
-        ; ECXDFN    = file #2 ien (required)
-        ; ECXDATE   = date of interest (required)
-        ; ECXPREFX  = prefix for provider data (optional)
-        ;             defaults to "2" if not specified otherwise
-        ; output
-        ; ECXPRIME  = pc team ien^prefix_pc provider ien^pc provider person
-        ;class^pc provider npi^prefix_assoc pc provider ien^assoc pc provider
-        ;person class^assoc pc provider npi
-        N ECPTTM,ECPTPR,ECCLAS,ECPRIME,ECASPR,ECCLAS2
-        S:'$D(ECXPREFX) ECXPREFX=2 S:(+ECXPREFX=0) ECXPREFX=2
-        ;get pc team data
-        S ECPTTM=+$$OUTPTTM^SDUTL3(ECXDFN,ECXDATE) S:ECPTTM=0 ECPTTM=""
-        ;get primary pc provider data
-        S ECPTPR=+$$OUTPTPR^SDUTL3(ECXDFN,ECXDATE)
-        S ECCLAS="" I ECPTPR>0 S ECCLAS=$$PRVCLASS^ECXUTL(ECPTPR,ECXDATE)
-        N ECXUSRTN S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",ECPTPR,ECXDATE)
-        S:+ECXUSRTN'>0 ECXUSRTN="" S ECPTNPI=$P(ECXUSRTN,U)
-        S:ECPTPR=0 ECPTPR="" S:ECPTPR]"" ECPTPR=ECXPREFX_ECPTPR
-        ;assoc pc provider call ok if routine scapmca from patch177 is present
-        S ECASPR=""
-        S X="SCAPMCA" X ^%ZOSF("TEST") I $T D
-        .S ECASPR=+$$OUTPTAP^SDUTL3(ECXDFN,ECXDATE)
-        S ECCLAS2="" I ECASPR>0 S ECCLAS2=$$PRVCLASS^ECXUTL(ECASPR,ECXDATE)
-        N ECXUSRTN S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",ECASPR,ECXDATE)
-        S:+ECXUSRTN'>0 ECXUSRTN="" S ECASNPI=$P(ECXUSRTN,U)
-        S:ECASPR=0 ECASPR="" S:ECASPR]"" ECASPR=ECXPREFX_ECASPR
-        ;assemble
-        S ECXPRIME=ECPTTM_U_ECPTPR_U_ECCLAS_U_ECPTNPI_U_ECASPR_U_ECCLAS2_U_ECASNPI
-        Q ECXPRIME
-INP(ECXDFN,ECXDATE)     ; check for inpatient status
-        ; input
-        ; ECXDFN  = file #2 ien (required)
-        ; ECXDATE = date of interest (required)
-        ; output
-        ; ECXINP  = patient status^movment # (file #405 ien)
-        ;       current treat. spec. (file #42.4 ien)^admission date/time^
-        ;       current ward (file #42 ien)^discharge date/time^
-        ;       ward provider^attending phys.^ward (file #44 ien);facility
-        ;       (file #40.8 ien);dss dept^dom
-        ;           where patient status = I for inpatient
-        ;                                = O for outpatient
-        N DFN,DSSDEPT,ECA,ECADM,ECMN,ECTS,ECWARD,ECDC,ECXINP,ECXPRO
-        N ECXATP,ECXDD,ECXDOM,ECXPROF,ECXPWP,ECXWW,FAC,VAIP,WRD,ECXPWPPC
-        N ECXATPPC
-        D FIELD^DID(405,.19,,"SPECIFIER","ECXDD")
-        S ECXPROF=$E(+$P(ECXDD("SPECIFIER"),"P",2)) K ECXDD
-        ;- Inpat/outpat indicator (ECA) initially set to "O" (outpatient)
-        S DFN=ECXDFN,ECA="O"
-        S (DSSDEPT,ECMN,ECTS,ECADM,ECWARD,ECDC,ECXATP,ECXPWP,ECXWW,WRD,FAC,ECXPWPPC,ECXATPPC)=""
-        S VAIP("D")=ECXDATE D IN5^VADPT
-        S ECMN=$G(VAIP(1))
-        I ECMN D
-        .S ECTS=+$P($G(^DIC(45.7,+VAIP(8),0)),U,2) S:ECTS=0 ECTS=""
-        .;- Get inpat/outpat indicator
-        .S ECA=$$INOUTP^ECXUTL4(ECTS)
-        .S ECADM=+$G(VAIP(13,1)) S:ECADM=0 ECADM=""
-        .S ECWARD=+$G(VAIP(5)) S:ECWARD=0 ECWARD=""
-        .I ECWARD D
-        ..S WRD=+$P($G(^DIC(42,+ECWARD,44)),U)
-        ..S FAC=$P($G(^DIC(42,+ECWARD,0)),U,11)
-        ..S DSSDEPT=$P($G(^ECX(727.4,ECWARD,0)),U,2)
-        .S ECXWW=WRD_";"_FAC_";"_DSSDEPT,ECDC=+$G(VAIP(17,1)) S:ECDC=0 ECDC=""
-        .S ECXPWP=+VAIP(7) S:ECXPWP=0 ECXPWP=""
-        .S ECXATP=+VAIP(18) S:ECXATP=0 ECXATP=""
-        .S ECXPWPPC=$$PRVCLASS^ECXUTL(ECXPWP,ECADM)
-        .S ECXATPPC=$$PRVCLASS^ECXUTL(ECXATP,ECADM)
-        .;prefix file #200 iens
-        .S:ECXPWP ECXPWP=ECXPROF_ECXPWP S:ECXATP ECXATP=ECXPROF_ECXATP
-        S ECXDOM=$P($G(^ECX(727.831,+ECTS,0)),U,2)
-        S ECXINP=ECA_U_ECMN_U_ECTS_U_ECADM_U_ECWARD_U_ECDC_U_ECXPWP_U_ECXATP_U_ECXWW_U_ECXDOM_U_ECXPWPPC_U_ECXATPPC
-        Q ECXINP
-VISN19(ECXDFN,ECXPAYOR,ECXSAI)  ;visn 19 sharing agreement data
-        ; input  ECXDFN = patient file ien
-        ; output ECXPAYOR, ECXSAI (passed by reference)
-        N JJ,ALIAS,INSUR,DIC,DIQ,DA,DR,ECXARY,ECXERR,ECXDA
-        S (ECXPAYOR,ECXSAI)=""
-        D GETS^DIQ(2,ECXDFN,"1*,","I","ECXARY","ECXERR")
-        I $D(ECXERR) Q
-        S JJ=0 F  S JJ=$O(ECXARY(2.01,JJ)) Q:JJ=""  D  I ECXPAYOR]"" Q
-        . S ALIAS=$G(ECXARY(2.01,JJ,.01,"I"))
-        . S ECXPAYOR=$S(ALIAS="SHARING AGREEMENT":"A",ALIAS="TRICARE":"B",ALIAS="CAT C":"C",ALIAS="CATEGORY C":"C",ALIAS="CHAMPVA":"D",ALIAS="CHAMPUS":"E",1:"")
-        . W !,$G(CNT)+1
-        . W !,"The value of ECXPAYOR is: ",ECXPAYOR
-        ;K ECXARY,ECXERR
-        I ECXPAYOR]"" D GETS^DIQ(2,ECXDFN,".3121*,","I","ECXARY","ECXERR") D
-        . I $D(ECXERR) Q
-        . S JJ=0,ECXDA=$O(ECXARY(2.312,JJ)) I ECXDA="" Q
-        . S DA=$G(ECXARY(2.312,ECXDA,.01,"I")) I DA="" Q
-        . S INSUR=$$GET1^DIQ(36,DA,".01","I","","ECXERR")
-        . I '$D(ECXERR) S ECXSAI=$E(ECXARY(2.312,ECXDA,.01,"I"),1,11)
-        Q
+ECXUTL2 ;ALB/JAP - Utilities for DSS Extracts (cont.) ; 11/2/06 9:03am
+ ;;3.0;DSS EXTRACTS;**8,13,23,24,33,35,39,46,71,84,92**;Dec 22, 1997;Build 30
+ ;
+ECXDEF(ECXHEAD,ECXPACK,ECXGRP,ECXFILE,ECXRTN,ECXPIECE,ECXVER) ;variables specific to extract from file #727.1
+ ;   input 
+ ;   ECXHEAD = extract header code
+ ;   all other formal list parameters passed by reference
+ ;   output
+ ;   ECXPACK = type field (#7)
+ ;   ECXGRP  = group field (#9)
+ ;   ECXFILE = file number field (#1)
+ ;   ECXRTN  = routine field (#4)
+ ;   ECXPIECE= running piece field (#11)
+ ;   ECXVER  = dss version
+ ;
+ N ECXIEN,ECXARR,DIC,DA,DR,DIQ
+ S (ECXPACK,ECXGRP,ECXFILE,ECXRTN,ECXPIECE,ECXVER)="",ECXIEN=0
+ S ECXIEN=+$O(^ECX(727.1,"C",ECXHEAD,ECXIEN))
+ I ECXIEN=0 D  Q
+ .D MES^XPDUTL(" ")
+ .D MES^XPDUTL(" It appears that you may have a problem with File #727.1 --")
+ .D MES^XPDUTL(" ")
+ .D MES^XPDUTL(" The "_ECHEAD_" Extract is not properly defined.")
+ .D MES^XPDUTL(" ")
+ .D MES^XPDUTL(" Contact National VISTA Support for further assistance.")
+ .D MES^XPDUTL(" ")
+ .I $E(IOST)="C" D
+ ..S SS=22-$Y F JJ=1:1:SS W !
+ ..S DIR(0)="E" W ! D ^DIR K DIR
+ .W !!
+ S DIC="^ECX(727.1,",DA=ECXIEN,DR=".01;1;4;7;9;11",DIQ="ECXARR"
+ D EN^DIQ1
+ S ECXPACK=ECXARR(727.1,ECXIEN,7)
+ ;if this is an inactive extract type, skip it
+ I ECXPACK["Inactive" D  Q
+ .D MES^XPDUTL(" ")
+ .D MES^XPDUTL(" The "_ECHEAD_" Extract is no longer active/valid.")
+ .D MES^XPDUTL(" ")
+ .D MES^XPDUTL(" Contact National VISTA Support for further assistance.")
+ .D MES^XPDUTL(" ")
+ .I $E(IOST)="C" D
+ ..S SS=22-$Y F JJ=1:1:SS W !
+ ..S DIR(0)="E" W ! D ^DIR K DIR
+ .W !!
+ S ECXGRP=ECXARR(727.1,ECXIEN,9)
+ S ECXFILE=ECXARR(727.1,ECXIEN,1)
+ S ECXRTN="START^"_ECXARR(727.1,ECXIEN,4)
+ S ECXPIECE=ECXARR(727.1,ECXIEN,11)
+ ;version of dss/tsi in Austin as specified by btso
+ S ECXVER=7
+ Q
+ ;
+PATDEM(DFN,DT1,PAR,FLG) ; determine patient information
+ ;  DFN   =
+ ;  DT    =
+ ;  PAR   =
+ ;  FLG   =
+ N DT2,PAT,OK,X
+ D KPATDEM
+ S FLG=$G(FLG),PAR=$S($D(PAR):PAR,1:"1;2;3;4;5;"),DT2=$P(DT1,".")
+ Q:'$$PAT^ECXUTL3(DFN,DT2,PAR,.PAT) 0
+ S ECXMPI=PAT("MPI")
+ I PAR["1" D
+ .S ECXSSN=PAT("SSN"),ECXPNM=PAT("NAME"),ECXDOB=PAT("DOB")
+ .S ECXSEX=PAT("SEX"),ECXREL=PAT("RELIGION"),ECXRACE=PAT("RACE")
+ .S ECXMAR=PAT("MARITAL")
+ .S ECXETH=PAT("ETHNIC"),ECXRC1=PAT("RACE1")
+ I PAR["2" D
+ .S ECXCNTY=PAT("COUNTY"),ECXSTATE=PAT("STATE"),ECXZIP=PAT("ZIP")
+ I PAR["3" D
+ .S ECXPOS=PAT("POS"),ECSC=PAT("SC STAT"),ECXSVC=PAT("SC%")
+ .S ECXVET=PAT("VET"),ECXMEAN=PAT("MEANS"),ECXELIG=PAT("ELIG")
+ .S ECXENRL=PAT("ENROLL LOC")
+ .S ECXERI=PAT("ERI")
+ I PAR["4" S ECXEMP=PAT("EMPLOY")
+ I PAR["5" D
+ .S ECXVIET=PAT("VIETNAM"),ECXAST=PAT("AO STAT"),ECXRST=PAT("IR STAT")
+ .S ECXEST=PAT("EC STAT"),ECXPST=PAT("POW STAT"),ECXPLOC=PAT("POW LOC")
+ .S ECXPHI=PAT("PHI"),ECXMST=PAT("MST STAT"),ECXAOL=PAT("AOL")
+ I PAR["6" D
+ .S (ECXPAYOR,ECXSAI)="" D VISN19(DFN,.ECXPAYOR,.ECXSAI)
+ I FLG'[3 D
+ .S X=$$PRIMARY(DFN,DT2),ECPTTM=$P(X,U),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3)
+ .S ECPTNPI=$P(X,U,4),ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6)
+ .S ECASNPI=$P(X,U,7)
+ I FLG'[2 D
+ .S ECXINP=$$INP^ECXUTL2(DFN,DT1),ECXA=$P(ECXINP,U),ECXMN=$P(ECXINP,U,2)
+ .S ECXTS=$P(ECXINP,U,3),ECXDOM=$P(ECXINP,U,10),ECXADMDT=$P(ECXINP,U,4)
+ I FLG'[1 S X=$$ENROLLM(DFN)
+ Q 1
+ ;
+KPATDEM ;
+ K ECXADMDT,ECAO,ECASNPI,ECASPR,ECCLAS,ECCLAS2,ECENV,ECPTNPI,ECPTPR,ECPTTM
+ K ECRE,ECSC,ECXA,ECXAST,ECXCAT,ECXCNTY,ECXEST,ECXENRL,ECXDOB
+ K ECXDOM,ECXELIG,ECXINP,ECXMPI,ECXMN,ECXNM,ECXPHI,ECXPLOC,ECXMEAN,ECXMST
+ K ECXPAYOR,ECXPNM,ECXPOS,ECXPRIOR,ECXPST,ECXRACE,ECXREL,ECXRST,ECXSAI
+ K ECXSEX,ECXSSN,ECXSTAT,ECXSTATE,ECXSVC,ECXTS,ECXVIET,ECXZIP,VA,VAERR
+ K ECXSBGRP
+ Q
+ ;
+ENROLLM(DFN,RNDT) ;determines enrollment status, category, priority
+ ;and user enrollee status
+ ; input
+ ;    DFN      = IEN from Patient file (Required)
+ ;    RNDT     = Extract Run Date
+ ; output
+ ;    ECXSTAT  = Enrollment status
+ ;    ECXPRIOR = Enrollment priority
+ ;    ECXCAT   = Enrollment priority
+ ;    ECXSBGRP = Enrollment subgroup
+ ;    ECXUESTA = User enrollee
+ ;    return value 0 if no data found, 1 if data found
+ ;
+ N CAT,PRIOR,STAT,X,X1,X2,X3,ENRIEN,ENR,FL,SBGRP
+ S (ECXCAT,ECXPRIOR,ECXSTAT,ECXSBGRP,ECXEUSTA)=""
+ I $G(DFN)="" Q 0
+ ;User enrollee status, if current or future date set to 'U'
+ ;DBIA #3989
+ S ECXUESTA=$S($$UESTAT^EASUER(DFN):"U",1:"")
+ ;Patient type
+ S ECXPTYPE=$$TYPE^ECXUTL5(DFN)
+ ;Combat Veteran Status DBIA #4156
+ S X3=$$CVEDT^ECXUTL5(DFN,$S($G(ECD):ECD,$G(ECXDATE):ECXDATE,1:DT))
+ ;enrollment priority DBIA
+ S STAT=$$STATUS^DGENA(DFN),PRIOR=$$PRIORITY^DGENA(DFN)
+ S CAT=$$CATEGORY^DGENA4(DFN,STAT),SBGRP=$$ENRSBGRP^DGENA4(DFN)
+ ;find current enrollment when status=2 or 19
+ I "^2^19^"[("^"_STAT_"^") S ECXSTAT=STAT,ECXPRIOR=PRIOR,ECXCAT=CAT,ECXSBGRP=$S(SBGRP=1:"a",SBGRP=3:"c",SBGRP=5:"e",SBGRP=7:"g",1:"") Q 1
+ ;find previous enrollment
+ S ENRIEN=$$FINDCUR^DGENA(DFN) I ENRIEN="" Q 0
+ I $G(RNDT)="" D NOW^%DTC S RNDT=X
+ S RNDT=($E(RNDT,1,3)-1)_$E(RNDT,4,7),FL=0
+ F  S ENRIEN=$$FINDPRI^DGENA(ENRIEN) Q:'ENRIEN  D  Q:FL
+ . S ENR=$$GET^DGENA(ENRIEN,.ENR)
+ . I "^2^19^"[("^"_ENR("STATUS")_"^"),ENR("EFFDATE")>RNDT D
+ . . S ECXSTAT=ENR("STATUS"),ECXPRIOR=PRIOR,FL=1
+ . . S ECXCAT=$$CATEGORY^DGENA4(DFN,ECXSTAT)
+ . . S ECXSBGRP=$$ENRSBGRP^DGENA4(DFN)
+ . . S ECXSBGRP=$S(SBGRP=1:"a",SBGRP=3:"c",SBGRP=5:"e",SBGRP=7:"g",1:"")
+ I FL Q 1
+ ;no enrollment status found =2 or 19
+ S ECXSTAT=STAT,ECXPRIOR=PRIOR,ECXCAT=CAT,ECXSBGRP=$S(SBGRP=1:"a",SBGRP=3:"c",SBGRP=5:"e",SBGRP=7:"g",1:"")
+ Q 1
+ ;
+PRIMARY(ECXDFN,ECXDATE,ECXPREFX) ;determine patient's pc team and pc provider
+ ; input
+ ; ECXDFN    = file #2 ien (required)
+ ; ECXDATE   = date of interest (required)
+ ; ECXPREFX  = prefix for provider data (optional)
+ ;             defaults to "2" if not specified otherwise
+ ; output
+ ; ECXPRIME  = pc team ien^prefix_pc provider ien^pc provider person class^pc provider npi
+ ;             ^prefix_assoc pc provider ien^assoc pc provider person class^assoc pc provider npi
+ ;
+ N ECPTTM,ECPTPR,ECCLAS,ECPRIME,ECASPR,ECCLAS2
+ S:'$D(ECXPREFX) ECXPREFX=2 S:(+ECXPREFX=0) ECXPREFX=2
+ ;get pc team data
+ S ECPTTM=+$$OUTPTTM^SDUTL3(ECXDFN,ECXDATE) S:ECPTTM=0 ECPTTM=""
+ ;get primary pc provider data
+ S ECPTPR=+$$OUTPTPR^SDUTL3(ECXDFN,ECXDATE)
+ S ECCLAS="" I ECPTPR>0 S ECCLAS=$$PRVCLASS^ECXUTL(ECPTPR,ECXDATE)
+ S:ECPTPR=0 ECPTPR="" S:ECPTPR]"" ECPTPR=ECXPREFX_ECPTPR
+ S ECPTNPI=""
+ ;assoc pc provider call ok if routine scapmca from patch177 is present
+ S ECASPR=""
+ S X="SCAPMCA" X ^%ZOSF("TEST") I $T D
+ .S ECASPR=+$$OUTPTAP^SDUTL3(ECXDFN,ECXDATE)
+ S ECCLAS2="" I ECASPR>0 S ECCLAS2=$$PRVCLASS^ECXUTL(ECASPR,ECXDATE)
+ S:ECASPR=0 ECASPR="" S:ECASPR]"" ECASPR=ECXPREFX_ECASPR
+ S ECASNPI=""
+ ;assemble
+ S ECXPRIME=ECPTTM_U_ECPTPR_U_ECCLAS_U_ECPTNPI_U_ECASPR_U_ECCLAS2_U_ECASNPI
+ Q ECXPRIME
+ ;
+INP(ECXDFN,ECXDATE) ; check for inpatient status
+ ; input
+ ; ECXDFN  = file #2 ien (required)
+ ; ECXDATE = date of interest (required)
+ ; output
+ ; ECXINP  = patient status^movment # (file #405 ien)
+ ;       current treat. spec. (file #42.4 ien)^admission date/time^
+ ;       current ward (file #42 ien)^discharge date/time^
+ ;       ward provider^attending phys.^ward (file #44 ien);facility
+ ;       (file #40.8 ien);dss dept^dom
+ ;           where patient status = I for inpatient
+ ;                                = O for outpatient
+ ;
+ N DFN,DSSDEPT,ECA,ECADM,ECMN,ECTS,ECWARD,ECDC,ECXINP,ECXPRO
+ N ECXATP,ECXDD,ECXDOM,ECXPROF,ECXPWP,ECXWW,FAC,VAIP,WRD,ECXPWPPC
+ N ECXATPPC
+ D FIELD^DID(405,.19,,"SPECIFIER","ECXDD")
+ S ECXPROF=$E(+$P(ECXDD("SPECIFIER"),"P",2)) K ECXDD
+ ;
+ ;- Inpat/outpat indicator (ECA) initially set to "O" (outpatient)
+ S DFN=ECXDFN,ECA="O"
+ S (DSSDEPT,ECMN,ECTS,ECADM,ECWARD,ECDC,ECXATP,ECXPWP,ECXWW,WRD,FAC,ECXPWPPC,ECXATPPC)=""
+ S VAIP("D")=ECXDATE D IN5^VADPT
+ S ECMN=$G(VAIP(1))
+ I ECMN D
+ .S ECTS=+$P($G(^DIC(45.7,+VAIP(8),0)),U,2) S:ECTS=0 ECTS=""
+ .;
+ .;- Get inpat/outpat indicator
+ .S ECA=$$INOUTP^ECXUTL4(ECTS)
+ .S ECADM=+$G(VAIP(13,1)) S:ECADM=0 ECADM=""
+ .S ECWARD=+$G(VAIP(5)) S:ECWARD=0 ECWARD=""
+ .I ECWARD D
+ ..S WRD=+$P($G(^DIC(42,+ECWARD,44)),U)
+ ..S FAC=$P($G(^DIC(42,+ECWARD,0)),U,11)
+ ..S DSSDEPT=$P($G(^ECX(727.4,ECWARD,0)),U,2)
+ .S ECXWW=WRD_";"_FAC_";"_DSSDEPT,ECDC=+$G(VAIP(17,1)) S:ECDC=0 ECDC=""
+ .S ECXPWP=+VAIP(7) S:ECXPWP=0 ECXPWP=""
+ .S ECXATP=+VAIP(18) S:ECXATP=0 ECXATP=""
+ .S ECXPWPPC=$$PRVCLASS^ECXUTL(ECXPWP,ECADM)
+ .S ECXATPPC=$$PRVCLASS^ECXUTL(ECXATP,ECADM)
+ .;prefix file #200 iens
+ .S:ECXPWP ECXPWP=ECXPROF_ECXPWP S:ECXATP ECXATP=ECXPROF_ECXATP
+ S ECXDOM=$P($G(^ECX(727.831,+ECTS,0)),U,2)
+ S ECXINP=ECA_U_ECMN_U_ECTS_U_ECADM_U_ECWARD_U_ECDC_U_ECXPWP_U_ECXATP_U_ECXWW_U_ECXDOM_U_ECXPWPPC_U_ECXATPPC
+ Q ECXINP
+ ;
+VISN19(ECXDFN,ECXPAYOR,ECXSAI) ;visn 19 sharing agreement data
+ ; input  ECXDFN = patient file ien
+ ; output ECXPAYOR, ECXSAI (passed by reference)
+ ;
+ N JJ,ALIAS,INSUR,DIC,DIQ,DA,DR,ECXARY,ECXERR,ECXDA
+ S (ECXPAYOR,ECXSAI)=""
+ D GETS^DIQ(2,ECXDFN,"1*,","I","ECXARY","ECXERR")
+ I $D(ECXERR) Q
+ S JJ=0 F  S JJ=$O(ECXARY(2.01,JJ)) Q:JJ=""  D  I ECXPAYOR]"" Q
+ . S ALIAS=$G(ECXARY(2.01,JJ,.01,"I"))
+ . S ECXPAYOR=$S(ALIAS="SHARING AGREEMENT":"A",ALIAS="TRICARE":"B",ALIAS="CAT C":"C",ALIAS="CATEGORY C":"C",ALIAS="CHAMPVA":"D",ALIAS="CHAMPUS":"E",1:"")
+ . W !,$G(CNT)+1
+ . W !,"The value of ECXPAYOR is: ",ECXPAYOR
+ ;K ECXARY,ECXERR
+ I ECXPAYOR]"" D GETS^DIQ(2,ECXDFN,".3121*,","I","ECXARY","ECXERR") D
+ . W !,"This is a test"
+ . I $D(ECXERR) Q
+ . S JJ=0,ECXDA=$O(ECXARY(2.312,JJ)) I ECXDA="" Q
+ . S DA=$G(ECXARY(2.312,ECXDA,.01,"I")) I DA="" Q
+ . S INSUR=$$GET1^DIQ(36,DA,".01","I","","ECXERR")
+ . I '$D(ECXERR) S ECXSAI=$E(ECXARY(2.312,ECXDA,.01,"I"),1,11)
+ Q

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXUTL3.m

@@ -1 @@
-ECXUTL3 ;ALB/GTS - Utilities for DSS Extracts ; 9/28/07 1:38pm
-        ;;3.0;DSS EXTRACTS;**11,24,32,33,35,37,39,42,46,92,105**;Dec 22,1997;Build 70
-        ;
-OUTPTTM(ECXDFN,ECXDT)   ;* Return PC Team from PCMM files or DPT
-        ; Variables -
-        ;            ECXDFN - IEN from Patient file (Required)
-        ;            ECXDT  - Relevant Date for Primary Care Team
-        ;                      (Defaults to DT)
-        ;
-        ; Returned: ECXTM -
-        ;            Pointer to team file (#404.51)
-        ;            or, if error or none defined, returns 0
-        ;
-        Q:'$G(ECXDFN) 0 ;** Quit if ECXDFN not defined
-        N ECXTM
-        S:'$D(ECXDT) ECXDT=DT
-        I $T(OUTPTTM^SDUTL3)[",SCDATE" D
-        .S ECXTM=+$$OUTPTTM^SDUTL3(ECXDFN,ECXDT)
-        I $T(OUTPTTM^SDUTL3)'[",SCDATE" D
-        .S ECXTM=+$$OUTPTTM^SDUTL3(ECXDFN)
-        I ECXTM=0 D
-        .S ECXTM=+$P($G(^DPT(+ECXDFN,"PC")),U,2)
-        Q ECXTM
-        ;
-OUTPTPR(ECXDFN,ECXDT)   ;* Return PC Provider from PCMM files or DPT
-        ; Variables -
-        ;            ECXDFN - IEN from Patient file (Required)
-        ;            ECXDT  - Relevant Date for Primary Care Provider
-        ;                      (Defaults to DT)
-        ;
-        ; Returned: ECXPR -
-        ;            Pointer to file #200 
-        ;            or, if error or none defined, returns a 0
-        ;
-        Q:'$G(ECXDFN) 0 ;** Quit if ECXDFN not defined
-        N ECXPR
-        S:'$D(ECXDT) ECXDT=DT
-        I $T(OUTPTPR^SDUTL3)[",SCDATE" D
-        .S ECXPR=+$$OUTPTPR^SDUTL3(ECXDFN,ECXDT)
-        I $T(OUTPTPR^SDUTL3)'[",SCDATE" D
-        .S ECXPR=+$$OUTPTPR^SDUTL3(ECXDFN)
-        I ECXPR=0 D
-        .S ECXPR=+$G(^DPT(+ECXDFN,"PC"))
-        Q ECXPR
-        ;
-PAT(ECXDFN,ECXDATE,ECXDATA,ECXPAT)      ;Return basic patient data for extract
-        ; Will not return data associated with test patients (SSN begin w 00000)
-        ; Variables -
-        ;  Input  ECXDFN - Patient internal entry number, DFN file#2; required
-        ;         ECXDATE- Date used to get specific data from GETSTAT^DGMSTAPI
-        ;                  for MST. If no date, defaults to today's date,
-        ;                  standard FM format, optional
-        ;         ECXDATA- Code indicating which data to return, optional.
-        ;                  If code not specified then returns all. Codes are:
-        ;                  1 - DEM^VADPT (demographic data)
-        ;                  2 - ADD^VADPT (current address)
-        ;                  3 - ELIG^VADPT (eligibility & enrollment location)
-        ;                  4 - OPD^VADPT (other patient data)
-        ;                  5 - SVC^VADPT & GETSTAT^DGMSTAPI (service & MST inf)
-        ;         ECXPAT(- Passed by reference; required
-        ;
-        ;  Output:
-        ;         ECXPAT   0 error or test patient no data in ECXPAT array
-        ;                  1 data returned in ECXPAT array
-        ;         ECXPAT(  Local array with patient data.
-        ;
-        N SSN,I,ECXCOD,ECXDAT,DFN,VAPA,VADM,VAEL,VAPD,VASV,STR,ECXAR,DIC,DIQ,RCNUM,RCVAL,COLMETH
-        N DA,DR,PELG,MELIG,ZIP,MPI
-        I ECXDFN="" Q 0
-        S SSN=$$GET1^DIQ(2,ECXDFN,.09,"I"),DFN=ECXDFN,ECXPAT=0
-        I $E(SSN,1,3)="000"!(SSN="") K ECXPAT Q 0  ;test patient
-        ;test patient extended checks; mtl extract excluded
-        I $G(ECHEAD)'="MTL",'$$SSN^ECXUTL5(SSN) K ECXPAT Q 0
-        S STR="NAME;SSN;DOB;SEX;RACE;RELIGION;STATE;COUNTY;ZIP;SC%;MEANS;ELIG;"
-        S STR=STR_"EMPLOY;AO STAT;IR STAT;EC STAT;POW STAT;POW LOC;MST STAT;"
-        S STR=STR_"ENROLL LOC;MPI;VIETNAM;POS;MARITAL"
-        ;initialize return array values
-        F I=1:1 S ECXDAT=$P(STR,";",I) Q:ECXDAT=""  S ECXPAT(ECXDAT)=""
-        F I=1:1:$L(ECXDATA,";") S ECXDAT=$P(ECXDATA,";",I) I ECXDAT'="" D
-        . S ECXCOD(ECXDAT)=""
-        ;
-        ;- Get ICN if MPI installed
-        S X="MPIF001" X ^%ZOSF("TEST") I $T D
-        .;
-        .;- Get 1st piece (either ICN # or -1 if error)
-        . S MPI=+$$GETICN^MPIF001(DFN)
-        .;
-        .;- If error, set to null
-        . S ECXPAT("MPI")=$S(MPI>0:MPI,1:"")
-        D  ;get demographic data
-        . I ECXDATA'="",'$D(ECXCOD(1)) Q
-        . D DEM^VADPT
-        . S ECXPAT("NAME")=$E($P(VADM(1),",")_"    ",1,4)
-        . S ECXPAT("SSN")=$P(VADM(2),U),ECXPAT("MARITAL")=$P(VADM(10),U)
-        . S ECXPAT("DOB")=$$ECXDOB^ECXUTL($P(VADM(3),U))
-        . S ECXPAT("SEX")=$P(VADM(5),U),ECXPAT("RELIGION")=$P(VADM(9),U)
-        . S DIC=10,DR=2,DA=+VADM(8),DIQ="ECXAR",DIQ(0)="I" D EN^DIQ1
-        . S ECXPAT("RACE")=$G(ECXAR(10,DA,DR,"I")),ECXPAT=1
-        . ;add new race and ethnicity fields for FY2003
-        . S (ECXPAT("ETHNIC"),ECXPAT("RACE1"))=""
-        . S X="DGUTL4" X ^%ZOSF("TEST") I $T D
-        .. S COLMETH=$$PTR2CODE^DGUTL4($G(VADM(11,1,1)),3,4) I COLMETH="S" D
-        ... S ECXPAT("ETHNIC")=$$PTR2CODE^DGUTL4(+$G(VADM(11,1)),2,4)
-        .. S (RCVAL,RCNUM)=""
-        .. F  S RCNUM=$O(VADM(12,RCNUM)) Q:RCNUM=""  Q:RCVAL="C"  S COLMETH=$$PTR2CODE^DGUTL4(+$G(VADM(12,RCNUM,1)),3,4) I COLMETH="S" D
-        ... S RCVAL=$$PTR2CODE^DGUTL4(+$G(VADM(12,RCNUM)),1,4)
-        ... I RCVAL="C" S ECXPAT("RACE1")=RCVAL Q
-        ... S ECXPAT("RACE1")=ECXPAT("RACE1")_RCVAL
-        D  ;get address information
-        . I ECXDATA'="",'$D(ECXCOD(2)) Q
-        . D ADD^VADPT
-        . S DIC=5,DR=2,DA=+VAPA(5),DIQ="ECXAR",DIQ(0)="I" D EN^DIQ1
-        . S ECXPAT("STATE")=$G(ECXAR(5,DA,DR,"I"))
-        . S DIC=5,DA=+VAPA(5),DR=3,DR(5.01)=2,DA(5.01)=+VAPA(7),DIQ="ECXAR"
-        . S DIQ(0)="I" D EN^DIQ1
-        . S ECXPAT("COUNTY")=$G(ECXAR(5.01,DA(5.01),2,"I"))
-        . S ECXPAT("ZIP")=$P(VAPA(11),U,2),ECXPAT=1
-        D  ;get eligibility information
-        . I ECXDATA'="",'$D(ECXCOD(3)) Q
-        . D ELIG^VADPT
-        . S PELG=$P(VAEL(1),U),MELIG=$S(PELG="":"",1:$$GET1^DIQ(8,PELG,8,"I"))
-        . S ECXPAT("POS")=$P($G(^DIC(21,+VAEL(2),0)),U,3)
-        . S ECXPAT("SC STAT")=$S(+VAEL(3):"Y",+VAEL(3)=0:"N",1:"")
-        . S ECXPAT("SC%")=$P(VAEL(3),U,2)
-        . S ECXPAT("VET")=$S(VAEL(4):"Y",VAEL(4)=0:"N",1:"")
-        . S ECXPAT("MEANS")=$P(VAEL(9),U),ECXPAT=1
-        . S ECXPAT("ELIG")=$$ELIG(MELIG,ECXPAT("SC%"))
-        . ;get enrollment location
-        . S DIC=2,DR=27.02,DA=ECXDFN,DIQ="ECXAR",DIQ(0)="I" D EN^DIQ1
-        . S ECXDAT=$G(ECXAR(2,ECXDFN,DR,"I")) I ECXDAT K ECXAR D
-        . . S DIC=4,DA=ECXDAT,DR=99,DIQ="ECXAR",DIQ(0)="I" D EN^DIQ1
-        . . S ECXPAT("ENROLL LOC")=ECXAR(4,ECXDAT,DR,"I")
-        . ;get Emergency Response Indicator (FEMA)
-        . S ECXPAT("ERI")=$$GET1^DIQ(2,ECXDFN,.181,"I")
-        D  ;get other patient information
-        . I ECXDATA'="",'$D(ECXCOD(4)) Q
-        . D OPD^VADPT
-        . S ECXPAT("EMPLOY")=$P(VAPD(7),U),ECXPAT=1
-        D  ;get service information
-        . I ECXDATA'="",'$D(ECXCOD(5)) Q
-        . D SVC^VADPT
-        . S ECXPAT("VIETNAM")=$S(VASV(1):"Y",VASV(2)=0:"N",1:"U")
-        . S ECXPAT("AO STAT")=$S(VASV(2):"Y",VASV(2)=0:"N",1:"U")
-        . S ECXPAT("IR STAT")=$S(VASV(3):"Y",VASV(3)=0:"N",1:"U")
-        . S ECXPAT("EC STAT")=$$GET1^DIQ(2,ECXDFN,.322013,"I")
-        . S ECXPAT("POW STAT")=$S(VASV(4):"Y",VASV(4)=0:"N",1:"U")
-        . S ECXPAT("POW LOC")=$P(VASV(4,3),U),ECXPAT=1
-        . S ECXPAT("PHI")=$S(VASV(9)=1:"Y",VASV(9)=0:"N",1:"")
-        . ;- Agent Orange Location (K=Korean DMZ,V=Vietnam)
-        . S ECXPAT("AOL")=$P($G(VASV(2,5)),U)
-        . ;get patient OEF/OIF status and date of return
-        . D OEFDATA^ECXUTL4
-        . ;
-        . ;get patient current MST status
-        . I ECXDATE'="",ECXDATE'["." S ECXDATE=ECXDATE+.9
-        . S X="DGMSTAPI" X ^%ZOSF("TEST") I $T D
-        . . S ECXDAT=$$GETSTAT^DGMSTAPI(DFN,ECXDATE)
-        . . S ECXPAT("MST STAT")=$S(+ECXDAT>0:$P(ECXDAT,U,2),1:"")
-        I 'ECXPAT K ECXPAT Q 0
-        Q 1
-        ;
-ELIG(ECXELIG,ECXSVCP)   ;Converts veteran eligibility code to NPCD code
-        ; Variables -
-        ;  Input  ECXELIG - Pointer to MAS ELIGIBILITY CODE file #8.1
-        ;         ECXSVCP - Number value rep. service connected percentage.
-        ;
-        ;  Output:
-        ;         ECXNCPD  NPCD Eligibility Code
-        ;
-        N TEXT,IEN,SCPER,FND,NPCD,I,ECXBG,ECXEN,ECXNPCD
-        I ECXELIG="" Q ""
-        F I=1:1 S TEXT=$P($T(ELGTXT+I),";",3,999) Q:TEXT="END"  D  I $D(NPCD) Q
-        . S IEN=$P(TEXT,";"),SCPER=$P(TEXT,";",2)
-        . I ECXELIG=IEN D
-        . . I SCPER="" S NPCD=$P(TEXT,";",3) Q
-        . . S ECXBG=$S($E(SCPER)="<":0,$E(SCPER)=">":$P(SCPER,">",2)+1,SCPER["-":+SCPER,1:"")
-        . . S ECXEN=$S($E(SCPER)="<":$P(SCPER,"<",2),$E(SCPER)=">":100,SCPER["-":$P(SCPER,"-",2),1:"")
-        . . I ECXSVCP'<ECXBG,ECXSVCP'>ECXEN S NPCD=$P(TEXT,";",3)
-        S ECXNPCD=$G(NPCD)
-        Q ECXNPCD
-ELGTXT  ;Eligibility codes
-        ;;1;>49;10;SC 50-100%
-        ;;2;;20;Aid & Attendance
-        ;;15;;21;Housebound
-        ;;16;;22;Mexican Border War
-        ;;17;;23;WWI
-        ;;18;;24;POW
-        ;;3;40-49;30;SC 40-49%
-        ;;3;30-39;31;SC 30-39%
-        ;;3;20-29;32;SC 20-29%
-        ;;3;10-19;33;SC 10-19%
-        ;;3;<10;34;SC less than 10%
-        ;;4;;40;NSC - VA Pension
-        ;;5;;50;NSC
-        ;;21;;60;Catastrophic Disability
-        ;;12;;101;CHAMPVA
-        ;;13;;102;Collateral of Veteran
-        ;;14;;103;Employee
-        ;;6;;104;Other Federal Agency
-        ;;7;;105;Allied Veteran
-        ;;8;;106;Humanitarian Emergency
-        ;;9;;107;Sharing Agreement
-        ;;10;;108;Reimbursable Insurance
-        ;;19;;109;TRICARE/CHAMPUS
-        ;;22;;25;Purple Heart Recipient
-        ;;END
-        ;
-CPT(ECXCPT,ECXMOD,ECXQUA)       ;Returns a str with CPT code and modifier codes
-        ;Return string is composed of a 5 character CPT code 2 character quantity
-        ;plus up to 5 modifier codes, 2 characters each.
-        ; Variables -
-        ;  Input  ECXCPT  - Pointer value to the CPT file (#81)
-        ;         ECXMOD - A string with pointer values to the CPT
-        ;                   MODIFIER file (#81.3) separated by ";"
-        ;         ECXQUA  - Number of time this procedure performed
-        ;
-        ;  Output:
-        ;         CPTMOD  - String of up to 17 characters, 5 character CPT
-        ;                   code 2 character qty plus up to 5 2-character
-        ;                   code modifiers.
-        ;
-        N CPT,MOD,I,CPTMOD
-        S ECXQUA=$G(ECXQUA,"01"),ECXMOD=$G(ECXMOD)
-        S:$L(ECXQUA)'=2 ECXQUA="0"_ECXQUA
-        S CPT=$$CPT^ICPTCOD(ECXCPT,"") I +CPT=-1 Q ""
-        S CPT=$P(CPT,U,2)_ECXQUA
-        F I=1:1:99 I $P(ECXMOD,";",I)'="" D
-        . S MOD=$$MOD^ICPTMOD($P(ECXMOD,";",I),"I","")
-        . I +MOD>0,$P(MOD,U,2)'="99" S CPT=CPT_$P(MOD,U,2)
-        S CPTMOD=$TR($E(CPT,1,17)," ")
-        Q CPTMOD
-        ;
-CPTOUT(ECXCPT)  ;output transform for CPT code plus modifiers
-        ;input  ECXCPT  - character string of CPT code plus modifiers (required)
-        ;
-        N J,CPTX,MOD,MODS,MODX,CPTMOD
-        Q:$G(ECXCPT)="" ""
-        S (CPTMOD,MODX)=""
-        S CPTX="("_+$E(ECXCPT,6,7)_") "_$E(ECXCPT,1,5),MODS=$E(ECXCPT,8,17)
-        F J=1:2:9 S MOD=$E(MODS,J,J+1) Q:MOD=""  D
-        .I J>1 S MODX=MODX_", "_MOD Q
-        .S MODX=MODX_"-"_MOD
-        S:$L(CPTX)>3 CPTMOD=CPTMOD_CPTX_MODX
-        Q CPTMOD
+ECXUTL3 ;ALB/GTS - Utilities for DSS Extracts ; 11/2/06 9:07am
+ ;;3.0;DSS EXTRACTS;**11,24,32,33,35,37,39,42,46,92**;Dec 22,1997;Build 30
+ ;
+OUTPTTM(ECXDFN,ECXDT) ;* Return PC Team from PCMM files or DPT
+ ; Variables -
+ ;            ECXDFN - IEN from Patient file (Required)
+ ;            ECXDT  - Relevant Date for Primary Care Team
+ ;                      (Defaults to DT)
+ ;
+ ; Returned: ECXTM -
+ ;            Pointer to team file (#404.51)
+ ;            or, if error or none defined, returns 0
+ ;
+ Q:'$G(ECXDFN) 0 ;** Quit if ECXDFN not defined
+ N ECXTM
+ S:'$D(ECXDT) ECXDT=DT
+ I $T(OUTPTTM^SDUTL3)[",SCDATE" D
+ .S ECXTM=+$$OUTPTTM^SDUTL3(ECXDFN,ECXDT)
+ I $T(OUTPTTM^SDUTL3)'[",SCDATE" D
+ .S ECXTM=+$$OUTPTTM^SDUTL3(ECXDFN)
+ I ECXTM=0 D
+ .S ECXTM=+$P($G(^DPT(+ECXDFN,"PC")),U,2)
+ Q ECXTM
+ ;
+OUTPTPR(ECXDFN,ECXDT) ;* Return PC Provider from PCMM files or DPT
+ ; Variables -
+ ;            ECXDFN - IEN from Patient file (Required)
+ ;            ECXDT  - Relevant Date for Primary Care Provider
+ ;                      (Defaults to DT)
+ ;
+ ; Returned: ECXPR -
+ ;            Pointer to file #200 
+ ;            or, if error or none defined, returns a 0
+ ;
+ Q:'$G(ECXDFN) 0 ;** Quit if ECXDFN not defined
+ N ECXPR
+ S:'$D(ECXDT) ECXDT=DT
+ I $T(OUTPTPR^SDUTL3)[",SCDATE" D
+ .S ECXPR=+$$OUTPTPR^SDUTL3(ECXDFN,ECXDT)
+ I $T(OUTPTPR^SDUTL3)'[",SCDATE" D
+ .S ECXPR=+$$OUTPTPR^SDUTL3(ECXDFN)
+ I ECXPR=0 D
+ .S ECXPR=+$G(^DPT(+ECXDFN,"PC"))
+ Q ECXPR
+ ;
+PAT(ECXDFN,ECXDATE,ECXDATA,ECXPAT) ;Return basic patient data for extract
+ ; Will not return data associated with test patients (SSN begin w 00000)
+ ; Variables -
+ ;  Input  ECXDFN - Patient internal entry number, DFN file#2; required
+ ;         ECXDATE- Date used to get specific data from GETSTAT^DGMSTAPI
+ ;                  for MST. If no date, defaults to today's date,
+ ;                  standard FM format, optional
+ ;         ECXDATA- Code indicating which data to return, optional.
+ ;                  If code not specified then returns all. Codes are:
+ ;                  1 - DEM^VADPT (demographic data)
+ ;                  2 - ADD^VADPT (current address)
+ ;                  3 - ELIG^VADPT (eligibility & enrollment location)
+ ;                  4 - OPD^VADPT (other patient data)
+ ;                  5 - SVC^VADPT & GETSTAT^DGMSTAPI (service & MST inf)
+ ;         ECXPAT(- Passed by reference; required
+ ;
+ ;  Output:
+ ;         ECXPAT   0 error or test patient no data in ECXPAT array
+ ;                  1 data returned in ECXPAT array
+ ;         ECXPAT(  Local array with patient data.
+ ;
+ N SSN,I,ECXCOD,ECXDAT,DFN,VAPA,VADM,VAEL,VAPD,VASV,STR,ECXAR,DIC,DIQ,RCNUM,RCVAL,COLMETH
+ N DA,DR,PELG,MELIG,ZIP,MPI
+ I ECXDFN="" Q 0
+ S SSN=$$GET1^DIQ(2,ECXDFN,.09,"I"),DFN=ECXDFN,ECXPAT=0
+ I $E(SSN,1,5)="00000"!(SSN="") K ECXPAT Q 0  ;test patient
+ S STR="NAME;SSN;DOB;SEX;RACE;RELIGION;STATE;COUNTY;ZIP;SC%;MEANS;ELIG;"
+ S STR=STR_"EMPLOY;AO STAT;IR STAT;EC STAT;POW STAT;POW LOC;MST STAT;"
+ S STR=STR_"ENROLL LOC;MPI;VIETNAM;POS;MARITAL"
+ ;initialize return array values
+ F I=1:1 S ECXDAT=$P(STR,";",I) Q:ECXDAT=""  S ECXPAT(ECXDAT)=""
+ F I=1:1:$L(ECXDATA,";") S ECXDAT=$P(ECXDATA,";",I) I ECXDAT'="" D
+ . S ECXCOD(ECXDAT)=""
+ ;
+ ;- Get ICN if MPI installed
+ S X="MPIF001" X ^%ZOSF("TEST") I $T D
+ .;
+ .;- Get 1st piece (either ICN # or -1 if error)
+ . S MPI=+$$GETICN^MPIF001(DFN)
+ .;
+ .;- If error, set to null
+ . S ECXPAT("MPI")=$S(MPI>0:MPI,1:"")
+ D  ;get demographic data
+ . I ECXDATA'="",'$D(ECXCOD(1)) Q
+ . D DEM^VADPT
+ . S ECXPAT("NAME")=$E($P(VADM(1),",")_"    ",1,4)
+ . S ECXPAT("SSN")=$P(VADM(2),U),ECXPAT("MARITAL")=$P(VADM(10),U)
+ . S ECXPAT("DOB")=$$ECXDOB^ECXUTL($P(VADM(3),U))
+ . S ECXPAT("SEX")=$P(VADM(5),U),ECXPAT("RELIGION")=$P(VADM(9),U)
+ . S DIC=10,DR=2,DA=+VADM(8),DIQ="ECXAR",DIQ(0)="I" D EN^DIQ1
+ . S ECXPAT("RACE")=$G(ECXAR(10,DA,DR,"I")),ECXPAT=1
+ . ;add new race and ethnicity fields for FY2003
+ . S (ECXPAT("ETHNIC"),ECXPAT("RACE1"))=""
+ . S X="DGUTL4" X ^%ZOSF("TEST") I $T D
+ .. S COLMETH=$$PTR2CODE^DGUTL4($G(VADM(11,1,1)),3,4) I COLMETH="S" D
+ ... S ECXPAT("ETHNIC")=$$PTR2CODE^DGUTL4(+$G(VADM(11,1)),2,4)
+ .. S (RCVAL,RCNUM)=""
+ .. F  S RCNUM=$O(VADM(12,RCNUM)) Q:RCNUM=""  Q:RCVAL="C"  S COLMETH=$$PTR2CODE^DGUTL4(+$G(VADM(12,RCNUM,1)),3,4) I COLMETH="S" D
+ ... S RCVAL=$$PTR2CODE^DGUTL4(+$G(VADM(12,RCNUM)),1,4)
+ ... I RCVAL="C" S ECXPAT("RACE1")=RCVAL Q
+ ... S ECXPAT("RACE1")=ECXPAT("RACE1")_RCVAL
+ D  ;get address information
+ . I ECXDATA'="",'$D(ECXCOD(2)) Q
+ . D ADD^VADPT
+ . S DIC=5,DR=2,DA=+VAPA(5),DIQ="ECXAR",DIQ(0)="I" D EN^DIQ1
+ . S ECXPAT("STATE")=$G(ECXAR(5,DA,DR,"I"))
+ . S DIC=5,DA=+VAPA(5),DR=3,DR(5.01)=2,DA(5.01)=+VAPA(7),DIQ="ECXAR"
+ . S DIQ(0)="I" D EN^DIQ1
+ . S ECXPAT("COUNTY")=$G(ECXAR(5.01,DA(5.01),2,"I"))
+ . S ECXPAT("ZIP")=$P(VAPA(11),U,2),ECXPAT=1
+ D  ;get eligibility information
+ . I ECXDATA'="",'$D(ECXCOD(3)) Q
+ . D ELIG^VADPT
+ . S PELG=$P(VAEL(1),U),MELIG=$S(PELG="":"",1:$$GET1^DIQ(8,PELG,8,"I"))
+ . S ECXPAT("POS")=$P($G(^DIC(21,+VAEL(2),0)),U,3)
+ . S ECXPAT("SC STAT")=$S(+VAEL(3):"Y",+VAEL(3)=0:"N",1:"")
+ . S ECXPAT("SC%")=$P(VAEL(3),U,2)
+ . S ECXPAT("VET")=$S(VAEL(4):"Y",VAEL(4)=0:"N",1:"")
+ . S ECXPAT("MEANS")=$P(VAEL(9),U),ECXPAT=1
+ . S ECXPAT("ELIG")=$$ELIG(MELIG,ECXPAT("SC%"))
+ . ;get enrollment location
+ . S DIC=2,DR=27.02,DA=ECXDFN,DIQ="ECXAR",DIQ(0)="I" D EN^DIQ1
+ . S ECXDAT=$G(ECXAR(2,ECXDFN,DR,"I")) I ECXDAT K ECXAR D
+ . . S DIC=4,DA=ECXDAT,DR=99,DIQ="ECXAR",DIQ(0)="I" D EN^DIQ1
+ . . S ECXPAT("ENROLL LOC")=ECXAR(4,ECXDAT,DR,"I")
+ . ;get Emergency Response Indicator (FEMA)
+ . S ECXPAT("ERI")=$$GET1^DIQ(2,ECXDFN,.181,"I")
+ D  ;get other patient information
+ . I ECXDATA'="",'$D(ECXCOD(4)) Q
+ . D OPD^VADPT
+ . S ECXPAT("EMPLOY")=$P(VAPD(7),U),ECXPAT=1
+ D  ;get service information
+ . I ECXDATA'="",'$D(ECXCOD(5)) Q
+ . D SVC^VADPT
+ . S ECXPAT("VIETNAM")=$S(VASV(1):"Y",VASV(2)=0:"N",1:"U")
+ . S ECXPAT("AO STAT")=$S(VASV(2):"Y",VASV(2)=0:"N",1:"U")
+ . S ECXPAT("IR STAT")=$S(VASV(3):"Y",VASV(3)=0:"N",1:"U")
+ . S ECXPAT("EC STAT")=$$GET1^DIQ(2,ECXDFN,.322013,"I")
+ . S ECXPAT("POW STAT")=$S(VASV(4):"Y",VASV(4)=0:"N",1:"U")
+ . S ECXPAT("POW LOC")=$P(VASV(4,3),U),ECXPAT=1
+ . S ECXPAT("PHI")=$S(VASV(9)=1:"Y",VASV(9)=0:"N",1:"")
+ . ;- Agent Orange Location (K=Korean DMZ,V=Vietnam)
+ . S ECXPAT("AOL")=$P($G(VASV(2,5)),U)
+ . ;get patient current MST status
+ . I ECXDATE'="",ECXDATE'["." S ECXDATE=ECXDATE+.9
+ . S X="DGMSTAPI" X ^%ZOSF("TEST") I $T D
+ . . S ECXDAT=$$GETSTAT^DGMSTAPI(DFN,ECXDATE)
+ . . S ECXPAT("MST STAT")=$S(+ECXDAT>0:$P(ECXDAT,U,2),1:"")
+ I 'ECXPAT K ECXPAT Q 0
+ Q 1
+ ;
+ELIG(ECXELIG,ECXSVCP) ;Converts veteran eligibility code to NPCD code
+ ; Variables -
+ ;  Input  ECXELIG - Pointer to MAS ELIGIBILITY CODE file #8.1
+ ;         ECXSVCP - Number value rep. service connected percentage.
+ ;
+ ;  Output:
+ ;         ECXNCPD  NPCD Eligibility Code
+ ;
+ N TEXT,IEN,SCPER,FND,NPCD,I,ECXBG,ECXEN,ECXNPCD
+ I ECXELIG="" Q ""
+ F I=1:1 S TEXT=$P($T(ELGTXT+I),";",3,999) Q:TEXT="END"  D  I $D(NPCD) Q
+ . S IEN=$P(TEXT,";"),SCPER=$P(TEXT,";",2)
+ . I ECXELIG=IEN D
+ . . I SCPER="" S NPCD=$P(TEXT,";",3) Q
+ . . S ECXBG=$S($E(SCPER)="<":0,$E(SCPER)=">":$P(SCPER,">",2)+1,SCPER["-":+SCPER,1:"")
+ . . S ECXEN=$S($E(SCPER)="<":$P(SCPER,"<",2),$E(SCPER)=">":100,SCPER["-":$P(SCPER,"-",2),1:"")
+ . . I ECXSVCP'<ECXBG,ECXSVCP'>ECXEN S NPCD=$P(TEXT,";",3)
+ S ECXNPCD=$G(NPCD)
+ Q ECXNPCD
+ELGTXT ;Eligibility codes
+ ;;1;>49;10;SC 50-100%
+ ;;2;;20;Aid & Attendance
+ ;;15;;21;Housebound
+ ;;16;;22;Mexican Border War
+ ;;17;;23;WWI
+ ;;18;;24;POW
+ ;;3;40-49;30;SC 40-49%
+ ;;3;30-39;31;SC 30-39%
+ ;;3;20-29;32;SC 20-29%
+ ;;3;10-19;33;SC 10-19%
+ ;;3;<10;34;SC less than 10%
+ ;;4;;40;NSC - VA Pension
+ ;;5;;50;NSC
+ ;;21;;60;Catastrophic Disability
+ ;;12;;101;CHAMPVA
+ ;;13;;102;Collateral of Veteran
+ ;;14;;103;Employee
+ ;;6;;104;Other Federal Agency
+ ;;7;;105;Allied Veteran
+ ;;8;;106;Humanitarian Emergency
+ ;;9;;107;Sharing Agreement
+ ;;10;;108;Reimbursable Insurance
+ ;;19;;109;TRICARE/CHAMPUS
+ ;;22;;25;Purple Heart Recipient
+ ;;END
+ ;
+CPT(ECXCPT,ECXMOD,ECXQUA) ;Returns a str with CPT code and modifier codes
+ ;Return string is composed of a 5 character CPT code 2 character quantity
+ ;plus up to 5 modifier codes, 2 characters each.
+ ; Variables -
+ ;  Input  ECXCPT  - Pointer value to the CPT file (#81)
+ ;         ECXMOD - A string with pointer values to the CPT
+ ;                   MODIFIER file (#81.3) separated by ";"
+ ;         ECXQUA  - Number of time this procedure performed
+ ;
+ ;  Output:
+ ;         CPTMOD  - String of up to 17 characters, 5 character CPT
+ ;                   code 2 character qty plus up to 5 2-character
+ ;                   code modifiers.
+ ;
+ N CPT,MOD,I,CPTMOD
+ S ECXQUA=$G(ECXQUA,"01"),ECXMOD=$G(ECXMOD)
+ S:$L(ECXQUA)'=2 ECXQUA="0"_ECXQUA
+ S CPT=$$CPT^ICPTCOD(ECXCPT,"") I +CPT=-1 Q ""
+ S CPT=$P(CPT,U,2)_ECXQUA
+ F I=1:1:99 I $P(ECXMOD,";",I)'="" D
+ . S MOD=$$MOD^ICPTMOD($P(ECXMOD,";",I),"I","")
+ . I +MOD>0,$P(MOD,U,2)'="99" S CPT=CPT_$P(MOD,U,2)
+ S CPTMOD=$TR($E(CPT,1,17)," ")
+ Q CPTMOD
+ ;
+CPTOUT(ECXCPT) ;output transform for CPT code plus modifiers
+ ;input  ECXCPT  - character string of CPT code plus modifiers (required)
+ ;
+ N J,CPTX,MOD,MODS,MODX,CPTMOD
+ Q:$G(ECXCPT)="" ""
+ S (CPTMOD,MODX)=""
+ S CPTX="("_+$E(ECXCPT,6,7)_") "_$E(ECXCPT,1,5),MODS=$E(ECXCPT,8,17)
+ F J=1:2:9 S MOD=$E(MODS,J,J+1) Q:MOD=""  D
+ .I J>1 S MODX=MODX_", "_MOD Q
+ .S MODX=MODX_"-"_MOD
+ S:$L(CPTX)>3 CPTMOD=CPTMOD_CPTX_MODX
+ Q CPTMOD

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXUTL4.m

@@ -1 @@
-ECXUTL4 ;ALB/ESD - Utilities for DSS Extracts ; 11/26/07 10:58am
-        ;;3.0;DSS EXTRACTS;**39,41,46,49,78,92,105**;Dec 22,1997;Build 70
-        ;
-OBSPAT(ECXIO,ECXTS,DSSID)       ;
-        ; Get observation patient indicator from DSS TREATING SPECIALTY
-        ; TRANSLATION file (#727.831) or DSS Identifier
-        ;
-        ; Input:
-        ;   ECXIO  - Inpatient/Outpatient indicator
-        ;   ECXTS  - Treating specialty (from file #42.4)
-        ;   DSSID  - DSS Identifier
-        ;
-        ;Output:
-        ;   ECXOBS - Observation patient indicator (YES/NO)
-        ;
-        ;- Check input vars
-        S ECXIO=$G(ECXIO),ECXTS=+$G(ECXTS),DSSID=+$G(DSSID)
-        S ECXOBS=""
-        D
-        .;- Look up obs patient indicator if treating spec is in file #727.831
-        . I $G(^ECX(727.831,ECXTS,0)) S ECXOBS=$P($G(^ECX(727.831,ECXTS,0)),"^",4)
-        . I ECXOBS'="" S ECXOBS=$S(ECXOBS="Y":"YES",1:"NO") Q
-        .;
-        .;- If outpatient and TS not in file, AND Feeder Key (CLI) or DSS ID
-        .;- (MTL,IVP,ECQ,QSR,NOS,SUR) is 290-296, Observation Patient Ind=YES
-        . I ECXIO="O",ECXOBS="",DSSID D
-        .. I $E(DSSID,1,3)>289&($E(DSSID,1,3)<297) S ECXOBS="YES"
-        .. E  S ECXOBS="NO"
-        Q $S(ECXOBS'="":ECXOBS,1:"NO")
-        ;
-INOUTP(ECXTS)   ;
-        ; Get inpatient/outpatient indicator from DSS TREATING SPECIALTY
-        ; TRANSLATION file (#727.831)
-        ;
-        ; Input:
-        ;   ECXTS   - Treating specialty
-        ;
-        ; Output:
-        ;             Inpatient/Outpatient indicator (I/O)
-        ;
-        S ECXTS=+$G(ECXTS)
-        S ECXIO=""
-        ;
-        ;- Look up inpat/outpat indicator if treating spec is in file
-        I $G(^ECX(727.831,ECXTS,0)) S ECXIO=$P($G(^ECX(727.831,ECXTS,0)),"^",5)
-        Q $S(ECXIO'="":ECXIO,1:"I")
-        ;
-ENCNUM(ECXIO,ECXSSN,ECXADT,ECXVDT,ECXTRT,ECXOBS,ECXEXT,ECXSTP,ECXSTP2)  ;
-        ; Get encounter number
-        ;
-        ; Input:
-        ;   ECXIO   - Inpat/Outpat indicator = I or O
-        ;   ECXSSN  - Patient SSN
-        ;   ECXADT  - Admit Date
-        ;   ECXVDT  - Visit Date
-        ;   ECXTRT  - Treating Spec
-        ;   ECXOBS  - Observation Pat Indicator
-        ;   ECXEXT  - Extract
-        ;   ECXSTP  - Stop Code (or stop code related) variable
-        ;   ECXSTP2 - Stop Code (or stop code related) addtl variable
-        ;             (used for SUR and ECS)
-        ;
-        ;Output:
-        ;             Encounter Number
-        ;
-        N ENCNUM,ECXDATE,ECXSTCD
-        S (ENCNUM,ECXSTCD)=""
-        ;
-        ;- Check input vars
-        S ECXEXT=$G(ECXEXT),ECXIO=$G(ECXIO),ECXOBS=$G(ECXOBS),ECXTRT=+$G(ECXTRT)
-        S ECXSTP=+$G(ECXSTP),ECXSTP2=+$G(ECXSTP2)
-        S ECXADT=+$G(ECXADT),ECXVDT=+$G(ECXVDT)
-        ;
-        ;- Don't use pseudo-SSN in encounter number
-        S ECXSSN=$E($G(ECXSSN),1,9)
-        ;
-        D
-        . ;- Inpatient
-        . I ECXIO="I",ECXADT,ECXSSN'="" D  Q
-        .. S ECXDATE=$$ADMITDT(ECXADT)
-        .. I ECXDATE'="" S ENCNUM=ECXSSN_ECXDATE_"I"
-        . ;
-        . ;- Outpatient branch
-        . I ECXIO="O" D
-        .. ;- Observation patient (outpatient)
-        .. I ECXOBS="YES",ECXSSN'="" D  Q
-        ... ;
-        ... S ECXDATE=$S(ECXADT:$$JULDT(ECXADT),1:$$JULDT(ECXVDT))
-        ... S ECXSTCD=$S(+$P($G(^ECX(727.831,ECXTRT,0)),"^",6):+$P($G(^ECX(727.831,ECXTRT,0)),"^",6),1:+$E(ECXSTP,1,3))
-        ... Q:ECXDATE=""!(ECXSTCD="")
-        ... S ENCNUM=ECXSSN_ECXDATE_ECXSTCD
-        .. ;
-        .. ;- Outpatient (no observation pat)
-        .. I ECXOBS="NO",ECXVDT,ECXSSN'="" D  Q
-        ... ;
-        ... ;- ADM, MOV, TRT have no outpat encounter number
-        ... I ECXEXT="ADM"!(ECXEXT="MOV")!(ECXEXT="TRT") Q
-        ... ;
-        ... ;- Use 1st 3 chars of DSS ID for NOS and ECQ (feeder key for CLI)
-        ... ;- Use observation stop code for IVP
-        ... I ECXEXT="CLI"!(ECXEXT="NOS")!(ECXEXT="ECQ")!(ECXEXT="IVP") S ECXSTCD=+$E(ECXSTP,1,3) Q:'ECXSTCD
-        ... ;
-        ... ;- Use cost center to obtain stop code for ECS
-        ... I ECXEXT="ECS" D  Q:'ECXSTCD
-        .... S ECXSTCD=$$ECSCOST(ECXSTP2)
-        ....;
-        ....;- If no cost center, use 1st 3 chars of DSS ID
-        .... I ECXSTCD="" S ECXSTCD=+$E(ECXSTP,1,3)
-        ... ;
-        ... ;- These extracts have predetermined stop code values
-        ... I ECXEXT="DEN" S ECXSTCD=180
-        ... I ECXEXT="PRE"!(ECXEXT="UDP") S ECXSTCD=160
-        ... I ECXEXT="LAB"!(ECXEXT="LAR")!(ECXEXT="LBB") S ECXSTCD=108
-        ... I ECXEXT="MTL" S ECXSTCD=538
-        ... I ECXEXT="NUR" S ECXSTCD=950
-        ... I ECXEXT="PRO" S ECXSTCD=423
-        ... I ECXEXT="NUT" S ECXSTCD="NUT"
-        ... ;
-        ... ;- If Imaging Type fld=2, use 109 otherwise use 105
-        ... I ECXEXT="RAD" S ECXSTCD=$S(ECXSTP=2:109,1:105)
-        ... ;
-        ... ;- Use DSS STOP CODE fld if populated or if SURG SPEC fld=59 use 430
-        ... ;- otherwise if null use 429
-        ... I ECXEXT="SUR" S ECXSTCD=$S(ECXSTP:ECXSTP,ECXSTP2=59:430,1:429)
-        ... ;
-        ... ;- Get Julian Date
-        ... S ECXDATE=$$JULDT(ECXVDT)
-        ... I ECXDATE'="" S ENCNUM=ECXSSN_ECXDATE_ECXSTCD
-        Q ENCNUM
-        ;
-ADMITDT(ECXINDT)        ; Returns date in YYMMDD format
-        ;
-        ; Input:
-        ;   ECXINDT - Date (can also include time) in internal FM format
-        ;
-        ;Output:
-        ;             Date in YYMMDD form
-        ;
-        N ECXDT
-        S ECXDT=""
-        S ECXINDT=+$G(ECXINDT)
-        ;
-        ;- If no input or full FM date not passed in, quit
-        I 'ECXINDT!($L(ECXINDT)<7) G ADMTDTQ
-        ;
-        ;- Date in YYMMDD form
-        S ECXDT=$TR($$FMTE^XLFDT(ECXINDT,"4DF")," /","0")
-ADMTDTQ Q ECXDT
-        ;
-        ;
-JULDT(ECXINDT)  ;  Returns Julian Date in MMDDD format
-        ;
-        ; Input:
-        ;   ECINDT  - Date (can also include time) in internal FM format
-        ;
-        ;Output:
-        ;             Julian date in MM_DDD form
-        ;
-        N ECXDDD,ECXDT,ECXJUL,ECXMM
-        S (ECXDDD,ECXMM)=""
-        ;
-        ;- If no input or full FM date not passed in, quit
-        S ECXINDT=+$G(ECXINDT)
-        I 'ECXINDT!($L(ECXINDT)<7) G JULDTQ
-        ;
-        ;- Extract date portion
-        S ECXDT=$E(ECXINDT,1,7)
-        ;
-        ;- Get month (MM)
-        S ECXMM=$E(ECXINDT,2,3)
-        ;
-        ;- Number of day within year (DDD)
-        S ECXDDD=$$RJ^XLFSTR($$FMDIFF^XLFDT(ECXDT,$E(ECXDT,1,3)_"0101",1)+1,3,"0")
-JULDTQ  Q ECXMM_ECXDDD
-        ;
-CNHSTAT(ECXDFN) ;  Get CNH (Contract Nursing Home) status
-        ;
-        ; Input:
-        ;   ECXDFN  - Patient DFN
-        ;
-        ;Output:
-        ;             CNH status (YES/NO)
-        ;
-        N ECXCNH
-        S ECXDFN=+$G(ECXDFN)
-        S ECXCNH=$P($G(^DPT(ECXDFN,"NHC")),U)
-        Q $S(ECXCNH="Y":"YES",ECXCNH="N":"NO",1:"")
-        ;
-CANC(ECXNOR,ECXTMOR)    ; Get Surgery Cancelled/Aborted Status
-        ;
-        ; Function called after determining CANCEL DATE in SURGERY record exists
-        ;
-        ; Input:
-        ;   ECXNOR   - Non-OR DSS ID
-        ;   ECXTMOR  - Time Pat in OR
-        ;
-        ;Output:
-        ;              Cancelled/aborted status (C/A)
-        ;
-        N ECXCANC
-        S ECXCANC=""
-        S ECXNOR=$G(ECXNOR)
-        ;
-        ;- If Non-OR DSS ID or Time Pat in OR, ECXCANC = "A" else = "C"
-        D
-        . I ECXNOR'=""&(ECXNOR'="UNKNOWN") S ECXCANC="A" Q
-        . I +$G(ECXTMOR) S ECXCANC="A" Q
-        . S ECXCANC="C"
-        Q ECXCANC
-        ;
-ECSCOST(ECXCOST)        ;Get ECS extract stop code based on cost center
-        ;
-        ;
-        ; Input:
-        ;   ECXCOST  - ECS extract cost center
-        ;
-        ;Output:
-        ;              ECS extract stop code
-        ;
-        N ECXFND,ECXSTOP,I
-        S ECXFND=0
-        S ECXSTOP=""
-        S ECXCOST=+$G(ECXCOST)
-        D
-        . I 'ECXCOST Q
-        . F I=1:1 Q:ECXFND!($P($T(COST+I),";;",2)="END")  D
-        .. I ECXCOST=$P($T(COST+I),";;",2) S ECXSTOP=$P($T(COST+I),";;",3),ECXFND=1
-        Q ECXSTOP
-        ;
-COST    ;- ECS Cost Center and stop code
-        ;;833100;;652
-        ;;833200;;653
-        ;;833300;;681
-        ;;834100;;651
-        ;;834200;;650
-        ;;834300;;681
-        ;;834400;;654
-        ;;834500;;681
-        ;;834600;;681
-        ;;834700;;681
-        ;;834800;;681
-        ;;834900;;681
-        ;;836100;;654
-        ;;836200;;654
-        ;;END
-        ;
-HNCI(ECXDFN)    ; Get head & neck cancer indicator
-        ;
-        ; Input:
-        ;   ECXDFN  - Patient DFN
-        ;
-        ;Output:
-        ;             Head/Neck CA DX (Y/N)
-        ;
-        N ECXHNCI,DGNT
-        S ECXHNCI=""
-        S ECXDFN=+$G(ECXDFN) I ECXDFN D
-        .I $$GETCUR^DGNTAPI(ECXDFN,"DGNT") S ECXHNCI=$P(DGNT("HNC"),U)
-        Q ECXHNCI
-        ;
-TSMAP(ECXTS)    ;Determines DSS Identifier for the following observation
-        ; treating specialty
-        ; Input:
-        ;   ECXTS - Observation Treating Specialty
-        ;
-        ; Output:
-        ;   DSS Identifier (Stop Code)
-        ;
-        N TS,SC,I
-        S TS="^18^23^24^36^41^65^94^",SC="^293^295^290^294^296^291^292^"
-        F I=1:1:$L(TS) Q:$P(TS,"^",I)=ECXTS
-        Q $P(SC,"^",I)_"000"
-OEFDATA ;
-        ;get patient OEF/OIF status and date of return
-        S (ECXOEF,ECXOEFDT)=""
-        I $G(VASV(11))>0 S ECXOEF=ECXOEF_"OIF"
-        I $G(VASV(12))>0 S ECXOEF=ECXOEF_"OEF"
-        I $G(VASV(13))>0 S ECXOEF=ECXOEF_"UNK"
-        I ECXOEF'="" D
-        . S ECXOEFDT=""
-        . I $G(VASV(11))>0 S ECXOEFDT=$P($G(VASV(11,$G(VASV(11)),3)),"^")
-        . I $G(VASV(12))>0,$P($G(VASV(12,$G(VASV(12)),3)),"^")>ECXOEFDT S ECXOEFDT=$P($G(VASV(12,$G(VASV(12)),3)),"^")
-        . I $G(VASV(13))>0,$P($G(VASV(13,$G(VASV(13)),3)),"^")>ECXOEFDT S ECXOEFDT=$P($G(VASV(13,$G(VASV(13)),3)),"^")
-        . I ECXOEFDT>0 S ECXOEFDT=17000000+ECXOEFDT
-        ;
-        S ECXPAT("ECXOEF")=ECXOEF
-        S ECXPAT("ECXOEFDT")=ECXOEFDT
-        Q
+ECXUTL4 ;ALB/ESD - Utilities for DSS Extracts ; 11/2/06 9:08am
+ ;;3.0;DSS EXTRACTS;**39,41,46,49,78,92**;Dec 22,1997;Build 30
+ ;
+OBSPAT(ECXIO,ECXTS,DSSID) ;
+ ; Get observation patient indicator from DSS TREATING SPECIALTY
+ ; TRANSLATION file (#727.831) or DSS Identifier
+ ;
+ ; Input:
+ ;   ECXIO  - Inpatient/Outpatient indicator
+ ;   ECXTS  - Treating specialty (from file #42.4)
+ ;   DSSID  - DSS Identifier
+ ;
+ ;Output:
+ ;   ECXOBS - Observation patient indicator (YES/NO)
+ ;
+ ;- Check input vars
+ S ECXIO=$G(ECXIO),ECXTS=+$G(ECXTS),DSSID=+$G(DSSID)
+ S ECXOBS=""
+ D
+ .;- Look up obs patient indicator if treating spec is in file #727.831
+ . I $G(^ECX(727.831,ECXTS,0)) S ECXOBS=$P($G(^ECX(727.831,ECXTS,0)),"^",4)
+ . I ECXOBS'="" S ECXOBS=$S(ECXOBS="Y":"YES",1:"NO") Q
+ .;
+ .;- If outpatient and TS not in file, AND Feeder Key (CLI) or DSS ID
+ .;- (MTL,IVP,ECQ,QSR,NOS,SUR) is 290-296, Observation Patient Ind=YES
+ . I ECXIO="O",ECXOBS="",DSSID D
+ .. I $E(DSSID,1,3)>289&($E(DSSID,1,3)<297) S ECXOBS="YES"
+ .. E  S ECXOBS="NO"
+ Q $S(ECXOBS'="":ECXOBS,1:"NO")
+ ;
+INOUTP(ECXTS) ;
+ ; Get inpatient/outpatient indicator from DSS TREATING SPECIALTY
+ ; TRANSLATION file (#727.831)
+ ;
+ ; Input:
+ ;   ECXTS   - Treating specialty
+ ;
+ ; Output:
+ ;             Inpatient/Outpatient indicator (I/O)
+ ;
+ S ECXTS=+$G(ECXTS)
+ S ECXIO=""
+ ;
+ ;- Look up inpat/outpat indicator if treating spec is in file
+ I $G(^ECX(727.831,ECXTS,0)) S ECXIO=$P($G(^ECX(727.831,ECXTS,0)),"^",5)
+ Q $S(ECXIO'="":ECXIO,1:"I")
+ ;
+ENCNUM(ECXIO,ECXSSN,ECXADT,ECXVDT,ECXTRT,ECXOBS,ECXEXT,ECXSTP,ECXSTP2) ;
+ ; Get encounter number
+ ;
+ ; Input:
+ ;   ECXIO   - Inpat/Outpat indicator = I or O
+ ;   ECXSSN  - Patient SSN
+ ;   ECXADT  - Admit Date
+ ;   ECXVDT  - Visit Date
+ ;   ECXTRT  - Treating Spec
+ ;   ECXOBS  - Observation Pat Indicator
+ ;   ECXEXT  - Extract
+ ;   ECXSTP  - Stop Code (or stop code related) variable
+ ;   ECXSTP2 - Stop Code (or stop code related) addtl variable
+ ;             (used for SUR and ECS)
+ ;
+ ;Output:
+ ;             Encounter Number
+ ;
+ N ENCNUM,ECXDATE,ECXSTCD
+ S (ENCNUM,ECXSTCD)=""
+ ;
+ ;- Check input vars
+ S ECXEXT=$G(ECXEXT),ECXIO=$G(ECXIO),ECXOBS=$G(ECXOBS),ECXTRT=+$G(ECXTRT)
+ S ECXSTP=+$G(ECXSTP),ECXSTP2=+$G(ECXSTP2)
+ S ECXADT=+$G(ECXADT),ECXVDT=+$G(ECXVDT)
+ ;
+ ;- Don't use pseudo-SSN in encounter number
+ S ECXSSN=$E($G(ECXSSN),1,9)
+ ;
+ D
+ . ;- Inpatient
+ . I ECXIO="I",ECXADT,ECXSSN'="" D  Q
+ .. S ECXDATE=$$ADMITDT(ECXADT)
+ .. I ECXDATE'="" S ENCNUM=ECXSSN_ECXDATE_"I"
+ . ;
+ . ;- Outpatient branch
+ . I ECXIO="O" D
+ .. ;- Observation patient (outpatient)
+ .. I ECXOBS="YES",ECXSSN'="" D  Q
+ ... ;
+ ... S ECXDATE=$S(ECXADT:$$JULDT(ECXADT),1:$$JULDT(ECXVDT))
+ ... S ECXSTCD=$S(+$P($G(^ECX(727.831,ECXTRT,0)),"^",6):+$P($G(^ECX(727.831,ECXTRT,0)),"^",6),1:+$E(ECXSTP,1,3))
+ ... Q:ECXDATE=""!(ECXSTCD="")
+ ... S ENCNUM=ECXSSN_ECXDATE_ECXSTCD
+ .. ;
+ .. ;- Outpatient (no observation pat)
+ .. I ECXOBS="NO",ECXVDT,ECXSSN'="" D  Q
+ ... ;
+ ... ;- ADM, MOV, TRT have no outpat encounter number
+ ... I ECXEXT="ADM"!(ECXEXT="MOV")!(ECXEXT="TRT") Q
+ ... ;
+ ... ;- Use 1st 3 chars of DSS ID for NOS and ECQ (feeder key for CLI)
+ ... ;- Use observation stop code for IVP
+ ... I ECXEXT="CLI"!(ECXEXT="NOS")!(ECXEXT="ECQ")!(ECXEXT="IVP") S ECXSTCD=+$E(ECXSTP,1,3) Q:'ECXSTCD
+ ... ;
+ ... ;- Use cost center to obtain stop code for ECS
+ ... I ECXEXT="ECS" D  Q:'ECXSTCD
+ .... S ECXSTCD=$$ECSCOST(ECXSTP2)
+ ....;
+ ....;- If no cost center, use 1st 3 chars of DSS ID
+ .... I ECXSTCD="" S ECXSTCD=+$E(ECXSTP,1,3)
+ ... ;
+ ... ;- These extracts have predetermined stop code values
+ ... I ECXEXT="DEN" S ECXSTCD=180
+ ... I ECXEXT="PRE"!(ECXEXT="UDP") S ECXSTCD=160
+ ... I ECXEXT="LAB"!(ECXEXT="LAR")!(ECXEXT="LBB") S ECXSTCD=108
+ ... I ECXEXT="MTL" S ECXSTCD=538
+ ... I ECXEXT="NUR" S ECXSTCD=950
+ ... I ECXEXT="PRO" S ECXSTCD=423
+ ... I ECXEXT="NUT" S ECXSTCD="NUT"
+ ... ;
+ ... ;- If Imaging Type fld=2, use 109 otherwise use 105
+ ... I ECXEXT="RAD" S ECXSTCD=$S(ECXSTP=2:109,1:105)
+ ... ;
+ ... ;- Use DSS STOP CODE fld if populated or if SURG SPEC fld=59 use 430
+ ... ;- otherwise if null use 429
+ ... I ECXEXT="SUR" S ECXSTCD=$S(ECXSTP:ECXSTP,ECXSTP2=59:430,1:429)
+ ... ;
+ ... ;- Get Julian Date
+ ... S ECXDATE=$$JULDT(ECXVDT)
+ ... I ECXDATE'="" S ENCNUM=ECXSSN_ECXDATE_ECXSTCD
+ Q ENCNUM
+ ;
+ADMITDT(ECXINDT) ; Returns date in YYMMDD format
+ ;
+ ; Input:
+ ;   ECXINDT - Date (can also include time) in internal FM format
+ ;
+ ;Output:
+ ;             Date in YYMMDD form
+ ;
+ N ECXDT
+ S ECXDT=""
+ S ECXINDT=+$G(ECXINDT)
+ ;
+ ;- If no input or full FM date not passed in, quit
+ I 'ECXINDT!($L(ECXINDT)<7) G ADMTDTQ
+ ;
+ ;- Date in YYMMDD form
+ S ECXDT=$TR($$FMTE^XLFDT(ECXINDT,"4DF")," /","0")
+ADMTDTQ Q ECXDT
+ ;
+ ;
+JULDT(ECXINDT) ;  Returns Julian Date in MMDDD format
+ ;
+ ; Input:
+ ;   ECINDT  - Date (can also include time) in internal FM format
+ ;
+ ;Output:
+ ;             Julian date in MM_DDD form
+ ;
+ N ECXDDD,ECXDT,ECXJUL,ECXMM
+ S (ECXDDD,ECXMM)=""
+ ;
+ ;- If no input or full FM date not passed in, quit
+ S ECXINDT=+$G(ECXINDT)
+ I 'ECXINDT!($L(ECXINDT)<7) G JULDTQ
+ ;
+ ;- Extract date portion
+ S ECXDT=$E(ECXINDT,1,7)
+ ;
+ ;- Get month (MM)
+ S ECXMM=$E(ECXINDT,2,3)
+ ;
+ ;- Number of day within year (DDD)
+ S ECXDDD=$$RJ^XLFSTR($$FMDIFF^XLFDT(ECXDT,$E(ECXDT,1,3)_"0101",1)+1,3,"0")
+JULDTQ Q ECXMM_ECXDDD
+ ;
+CNHSTAT(ECXDFN) ;  Get CNH (Contract Nursing Home) status
+ ;
+ ; Input:
+ ;   ECXDFN  - Patient DFN
+ ;
+ ;Output:
+ ;             CNH status (YES/NO)
+ ;
+ N ECXCNH
+ S ECXDFN=+$G(ECXDFN)
+ S ECXCNH=$P($G(^DPT(ECXDFN,"NHC")),U)
+ Q $S(ECXCNH="Y":"YES",ECXCNH="N":"NO",1:"")
+ ;
+CANC(ECXNOR,ECXTMOR) ; Get Surgery Cancelled/Aborted Status
+ ;
+ ; Function called after determining CANCEL DATE in SURGERY record exists
+ ;
+ ; Input:
+ ;   ECXNOR   - Non-OR DSS ID
+ ;   ECXTMOR  - Time Pat in OR
+ ;
+ ;Output:
+ ;              Cancelled/aborted status (C/A)
+ ;
+ N ECXCANC
+ S ECXCANC=""
+ S ECXNOR=$G(ECXNOR)
+ ;
+ ;- If Non-OR DSS ID or Time Pat in OR, ECXCANC = "A" else = "C"
+ D
+ . I ECXNOR'=""&(ECXNOR'="UNKNOWN") S ECXCANC="A" Q
+ . I +$G(ECXTMOR) S ECXCANC="A" Q
+ . S ECXCANC="C"
+ Q ECXCANC
+ ;
+ECSCOST(ECXCOST) ;Get ECS extract stop code based on cost center
+ ;
+ ;
+ ; Input:
+ ;   ECXCOST  - ECS extract cost center
+ ;
+ ;Output:
+ ;              ECS extract stop code
+ ;
+ N ECXFND,ECXSTOP,I
+ S ECXFND=0
+ S ECXSTOP=""
+ S ECXCOST=+$G(ECXCOST)
+ D
+ . I 'ECXCOST Q
+ . F I=1:1 Q:ECXFND!($P($T(COST+I),";;",2)="END")  D
+ .. I ECXCOST=$P($T(COST+I),";;",2) S ECXSTOP=$P($T(COST+I),";;",3),ECXFND=1
+ Q ECXSTOP
+ ;
+COST ;- ECS Cost Center and stop code
+ ;;833100;;652
+ ;;833200;;653
+ ;;833300;;681
+ ;;834100;;651
+ ;;834200;;650
+ ;;834300;;681
+ ;;834400;;654
+ ;;834500;;681
+ ;;834600;;681
+ ;;834700;;681
+ ;;834800;;681
+ ;;834900;;681
+ ;;836100;;654
+ ;;836200;;654
+ ;;END
+ ;
+HNCI(ECXDFN) ; Get head & neck cancer indicator
+ ;
+ ; Input:
+ ;   ECXDFN  - Patient DFN
+ ;
+ ;Output:
+ ;             Head/Neck CA DX (Y/N)
+ ;
+ N ECXHNCI,DGNT
+ S ECXHNCI=""
+ S ECXDFN=+$G(ECXDFN) I ECXDFN D
+ .I $$GETCUR^DGNTAPI(ECXDFN,"DGNT") S ECXHNCI=$P(DGNT("HNC"),U)
+ Q ECXHNCI
+ ;
+TSMAP(ECXTS) ;Determines DSS Identifier for the following observation
+ ; treating specialty
+ ; Input:
+ ;   ECXTS - Observation Treating Specialty
+ ;
+ ; Output:
+ ;   DSS Identifier (Stop Code)
+ ;
+ N TS,SC,I
+ S TS="^18^23^24^36^41^65^94^",SC="^293^295^290^294^296^291^292^"
+ F I=1:1:$L(TS) Q:$P(TS,"^",I)=ECXTS
+ Q $P(SC,"^",I)_"000"

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXUTL5.m

@@ -1 @@
-ECXUTL5 ;ALB/JRC - Utilities for DSS Extracts ; 10/17/07 3:49pm
-        ;;3.0;DSS EXTRACTS;**71,84,92,103,105**;Dec 22, 1997;Build 70
-        ;
-REPEAT(CHAR,TIMES)      ;REPEAT A STRING
-        ;INPUT  : CHAR - Character to repeat
-        ;         TIMES - Number of times to repeat CHAR
-        ;OUTPUT : s - String of CHAR that is TIMES long
-        ;         "" - Error (bad input)
-        ;
-        ;CHECK INPUT
-        Q:($G(CHAR)="") ""
-        Q:((+$G(TIMES))=0) ""
-        ;RETURN STRING
-        Q $TR($J("",TIMES)," ",CHAR)
-INSERT(INSTR,OUTSTR,COLUMN,LENGTH)      ;INSERT A STRING INTO ANOTHER
-        ;INPUT  : INSTR - String to insert
-        ;         OUTSTR - String to insert into
-        ;         COLUMN - Where to begin insertion (defaults to end of OUTSTR)
-        ;         LENGTH - Number of characters to clear from OUTSTR
-        ;                  (defaults to length of INSTR)
-        ;OUTPUT : s - INSTR will be placed into OUTSTR starting at COLUMN
-        ;             using LENGTH characters
-        ;         "" - Error (bad input)
-        ;
-        ;NOTE : This module is based on $$SETSTR^VALM1
-        ;
-        ;CHECK INPUT
-        Q:('$D(INSTR)) ""
-        Q:('$D(OUTSTR)) ""
-        S:('$D(COLUMN)) COLUMN=$L(OUTSTR)+1
-        S:('$D(LENGTH)) LENGTH=$L(INSTR)
-        ;DECLARE VARIABLES
-        N FRONT,END
-        S FRONT=$E((OUTSTR_$J("",COLUMN-1)),1,(COLUMN-1))
-        S END=$E(OUTSTR,(COLUMN+LENGTH),$L(OUTSTR))
-        ;INSERT STRING
-        Q FRONT_$E((INSTR_$J("",LENGTH)),1,LENGTH)_END
-TYPE(DFN)       ;Determine patient type DBIA #2511
-        ;   input 
-        ;   DFN = patient ien
-        ;
-        ;   output
-        ;   ECXPTYPE = patient type external value from fle 391
-        ;
-        ;          AC = ACTIVE DUTY        MI = MILITARY RETIREE
-        ;          AL = ALLIED VETERAN     NO = NON-VETERAN (OTHER)
-        ;          CO = COLLATERAL         NS = NSC VETERAN
-        ;          EM = EMPLOYEE           SC = SC VETERAN
-        ;          IN = INELIGIBLE         TR = TRICARE
-        ;          return value 0 if no data found, 1 if data found
-        ;
-        N TYPE,ECXPTYPE
-        ;Check input
-        Q:'$D(DFN) ""
-        S (TYPE,ECXPTYPE)=""
-        S TYPE=$G(^DPT(DFN,"TYPE"))
-        I 'TYPE Q ECXPTYPE
-        S ECXPTYPE=$P($G(^DG(391,TYPE,0)),U,1)
-        S ECXPTYPE=$E(ECXPTYPE,1,2)
-        Q ECXPTYPE
-CVEDT(DFN,DATE) ;Determine patient CV status DBIA #4156
-        ;   input
-        ;   DFN = patient ien
-        ;
-        ;   output
-        ;   ECXCVE = combat veteran status eligibility
-        ;   ECXCVEDT = combat veteran eligibility end date
-        ;   ECXCVENC = combat veteran encounter
-        ;Initialize variables
-        N CVSTAT
-        S (CVSTAT,ECXCVE,ECXCVEDT,ECXCVENC)=""
-        ;Check input
-        Q:'$D(DFN) 0
-        ;Call CV API
-        S CVSTAT=$$CVEDT^DGCV(DFN,DATE)
-        I CVSTAT<1 Q 0
-        ;Veteran been given CV eligibility
-        S ECXCVE=$S($P(CVSTAT,U,3)=1:"Y",$P(CVSTAT,U,3)=0:"E",1:"")
-        ;Save CV eligibility end date and convert from FM to HL7 format
-        S ECXCVEDT=$P(CVSTAT,U,2)
-        S ECXCVEDT=$$FMTHL7^XLFDT(ECXCVEDT)
-        ;Is the veteran eligible for CV in the date of encounter
-        S ECXCVENC=$S($P(CVSTAT,U,3)=1:"Y",1:"")
-        Q 1
-NPRF    ;National patient record flags DBIA #3860
-        N ECXARR,FLG
-        S ECXNPRFI="",CNT=$$GETACT^DGPFAPI(ECXDFN,"ECXARR"),FLG=""
-        I 'CNT Q
-        F I=1:1:CNT D  Q:FLG
-        .I ECXARR(I,"CATEGORY")["NATIONAL" S ECXNPRFI="Y",FLG=1
-        Q
-RXPTST(K)       ;Rx patient status DBIA #2511
-        N ECXDIC,STAT
-        S (ECXDIC,STAT)=""
-        ;Check input
-        Q:'$D(K) STAT
-        S DA=K,DIC="^PS(53,",DIQ(0)="I",DIQ="ECXDIC",DR="6"
-        D EN^DIQ1
-        S STAT=$G(ECXDIC(53,K,6,"I"))
-        S STAT=$S(STAT=1:"SC",STAT=2:"AA",STAT=3:"OTH",STAT=4:"INP",STAT=5:"NON",1:"")
-        Q STAT
-NONVAP(K)       ;Non-va prescriber DBIA #10060
-        N ECXDIC,NONVAP
-        S (ECXDIC,NONVAP)=""
-        Q:'$D(K) NONVAP
-        S DA=K,DIC="^VA(200,",DIQ(0)="I",DIQ="ECXDIC",DR="53.91"
-        D EN^DIQ1
-        S NONVAP=$G(ECXDIC(200,K,53.91,"I"))
-        I NONVAP S NONVAP="Y"
-        Q NONVAP
-DOIVPO(K,L)     ;Add destination for outpatient ivp orders
-        ;     Input     K - DFN
-        ;               L - Order # from Pharmacy Patient File (#55)
-        ;
-        ;     Output     ordering stop code
-        ;
-        N ECXDIC,ECXDICA,ECXDICB,DOIVPO,CLINIC,SCODE,DIC,DIQ,DR,DA
-        S (ECXDIC,ECXDICA,ECXDICB,DOIVPO,CLINIC,SCODE)=""
-        ;Check input
-        Q:'K!'(L) SCODE
-        ;Check treating specialty
-        S SCODE=$$TSSC($G(ECXTS)) I SCODE>0 Q SCODE
-        ;Go to pharmacy patient file (#55) and return value of field (#136)
-        S DIC=55,DIQ(0)="I",DIQ="ECXDIC",DR="100",DR(55.01)="136",DA=K,DA(55.01)=L
-        D EN^DIQ1
-        S CLINIC=$G(ECXDIC(55.01,L,136,"I"))
-        I 'CLINIC Q SCODE
-        ;Get stop code pointer to file 40.7 from file 44
-        S DIC="^SC(",DIQ(0)="I",DIQ="ECXDICA",DR="8",DA=CLINIC D EN^DIQ1
-        S SCODE=ECXDICA(44,CLINIC,8,"I")
-        ;Get stop code external value
-        S DIC="^DIC(40.7,",DIQ(0)="E",DIQ="ECXDICB",DR="1",DA=SCODE D EN^DIQ1
-        S SCODE=$G(ECXDICB(40.7,SCODE,1,"E"))
-        Q SCODE
-        ;
-DOUDO(K,L)      ;Add destination for outpatient udp orders
-        ;     Input     K - DFN
-        ;               L - Order # from Pharmacy Patient File (#55)
-        ;
-        ;     Output     ordering stop code
-        ;
-        N ECXDIC,ECXDICA,ECXDICB,DOIVPO,CLINIC,SCODE,DIC,DIQ,DR,DA
-        S (ECXDIC,ECXDICA,ECXDICB,DOIVPO,CLINIC,SCODE)=""
-        ;Check treating specialty
-        S SCODE=$$TSSC($G(ECXTS)) I SCODE>0 Q SCODE
-        ;Check input
-        Q:'K!'(L) SCODE
-        S DIC=55,DIQ(0)="I",DIQ="ECXDIC",DR="62",DR(55.06)="130",DA=K,DA(55.06)=L
-        D EN^DIQ1
-        S CLINIC=$G(ECXDIC(55.06,L,130,"I"))
-        I 'CLINIC Q SCODE
-        ;Get stop code pointer to file 40.7 from file 44
-        S DIC="^SC(",DIQ(0)="I",DIQ="ECXDICA",DR="8",DA=CLINIC D EN^DIQ1
-        S SCODE=ECXDICA(44,CLINIC,8,"I")
-        ;Get stop code external value
-        S DIC="^DIC(40.7,",DIQ(0)="E",DIQ="ECXDICB",DR="1",DA=SCODE D EN^DIQ1
-        S SCODE=$G(ECXDICB(40.7,SCODE,1,"E"))
-        Q SCODE
-        ;
-PHAAPI(DRUG)    ;Call Pharmacy drug file API dbia 4483
-        ;   Input: drug file (#50) ien
-        ;
-        ;   Output: generic name ^ classification ^ ndc ^ dea hand
-        ;            ^ ndf file entry # ^ psndf va product entry ^
-        ;            price per disp unit ^ dispense unit
-        ;
-        ;Initialize variables and scratch global
-        N NAME,CLASS,NDC,INV,NDF,P1,P3,PPDU,UNIT,ARRAY,DATA
-        S (NAME,CLASS,NDC,INV,NDF,P1,P3,PPDU,ARRAY,DATA)=""
-        S ARRAY="^TMP($J,""ECXLIST"")"
-        K @ARRAY
-        D DATA^PSS50(DRUG,,,,,"ECXLIST")
-        I @ARRAY@(0)'>0 Q "^^^^^^"
-        S NAME=@ARRAY@(DRUG,.01),CLASS=@ARRAY@(DRUG,2),NDC=@ARRAY@(DRUG,31)
-        S INV=@ARRAY@(DRUG,3),P1=$P(@ARRAY@(DRUG,20),U),P3=$P(@ARRAY@(DRUG,22),U),PPDU=@ARRAY@(DRUG,16),UNIT=@ARRAY@(DRUG,14.5)
-        K @ARRAY
-        Q NAME_U_CLASS_U_NDC_U_INV_U_P1_U_P3_U_PPDU_U_UNIT
-        ;
-TSSC(X) ;Check treating specialty (ts) and if ts equals any of the following
-        ;18,23,24,36,41,65,94 then assign predefined code and return value
-        ;
-        ;    Input: treating specialty
-        ;    Output: Ordering stop code
-        ;
-        S CODE=$S(X=18:293,X=23:295,X=24:290,X=36:294,X=41:296,X=65:291,X=94:292,1:"")
-        Q CODE
-        ;
-PSJ59P5(X)      ;Get iv room division
-        ;   Input  X - iv room ien
-        ;
-        ;   Output - field .02 division
-        ;Init variables
-        N DIV S DIV=""
-        ;Check input
-        I 'X  Q DIV
-        D ALL^PSJ59P5(X,,"ECXDIV")
-        S DIV=$P($G(^TMP($J,"ECXDIV",X,.02)),U)
-        K ^TMP($J,"ECXDIV")
-        Q DIV
-        ;
-SCRX(IEN)       ;Service connected prescription
-        ;Init variables
-        N DIC,DR,DA,ECXDIQ
-        ;Check input
-        I '$G(IEN) Q ""
-        S DIC=52,DR="116",DA=IEN,DIQ="ECXDIQ"
-        D DIQ^PSODI(DIC,DIC,DR,DA,DIQ)
-        Q $S($G(ECXDIQ(52,DA,116))="YES":"Y",$G(ECXDIQ(52,DA,116))="NO":"N",1:"")
-        ;
-SSN(SSN,FILE)   ; extended validation of ssn
-        ;       input:     ssn - social security number to validate
-        ;                  file - optional "", 2 or 67, the only check is for
-        ;                         reference lab file (#67) in which case ssn
-        ;                         "000123456" is considered a valid ssn.
-        ;        output:   0 - test patient or invalid ssn
-        ;                  1 - valid ssn
-        ;
-        ;check input
-        I $G(SSN)']"" Q 0
-        S FILE=$G(FILE)
-        I (FILE=67)&(SSN="000123456") Q 1
-        I "89"[$E(SSN) Q 0
-        I (SSN="123456789")!(SSN="111111111")!(SSN="222222222")!(SSN="333333333")!(SSN="444444444")!(SSN="555555555")!($E(SSN,1,3)="666")!($E(SSN,4,5)="00")!($E(SSN,1,3)="000") Q 0
-        Q 1
+ECXUTL5 ;ALB/JRC - Utilities for DSS Extracts ; 01/18/07 9:04am
+ ;;3.0;DSS EXTRACTS;**71,84,92,103**;Dec 22, 1997;Build 1
+ ;
+REPEAT(CHAR,TIMES) ;REPEAT A STRING
+ ;INPUT  : CHAR - Character to repeat
+ ;         TIMES - Number of times to repeat CHAR
+ ;OUTPUT : s - String of CHAR that is TIMES long
+ ;         "" - Error (bad input)
+ ;
+ ;CHECK INPUT
+ Q:($G(CHAR)="") ""
+ Q:((+$G(TIMES))=0) ""
+ ;RETURN STRING
+ Q $TR($J("",TIMES)," ",CHAR)
+INSERT(INSTR,OUTSTR,COLUMN,LENGTH) ;INSERT A STRING INTO ANOTHER
+ ;INPUT  : INSTR - String to insert
+ ;         OUTSTR - String to insert into
+ ;         COLUMN - Where to begin insertion (defaults to end of OUTSTR)
+ ;         LENGTH - Number of characters to clear from OUTSTR
+ ;                  (defaults to length of INSTR)
+ ;OUTPUT : s - INSTR will be placed into OUTSTR starting at COLUMN
+ ;             using LENGTH characters
+ ;         "" - Error (bad input)
+ ;
+ ;NOTE : This module is based on $$SETSTR^VALM1
+ ;
+ ;CHECK INPUT
+ Q:('$D(INSTR)) ""
+ Q:('$D(OUTSTR)) ""
+ S:('$D(COLUMN)) COLUMN=$L(OUTSTR)+1
+ S:('$D(LENGTH)) LENGTH=$L(INSTR)
+ ;DECLARE VARIABLES
+ N FRONT,END
+ S FRONT=$E((OUTSTR_$J("",COLUMN-1)),1,(COLUMN-1))
+ S END=$E(OUTSTR,(COLUMN+LENGTH),$L(OUTSTR))
+ ;INSERT STRING
+ Q FRONT_$E((INSTR_$J("",LENGTH)),1,LENGTH)_END
+TYPE(DFN) ;Determine patient type DBIA #2511
+ ;   input 
+ ;   DFN = patient ien
+ ;
+ ;   output
+ ;   ECXPTYPE = patient type external value from fle 391
+ ;
+ ;          AC = ACTIVE DUTY        MI = MILITARY RETIREE
+ ;          AL = ALLIED VETERAN     NO = NON-VETERAN (OTHER)
+ ;          CO = COLLATERAL         NS = NSC VETERAN
+ ;          EM = EMPLOYEE           SC = SC VETERAN
+ ;          IN = INELIGIBLE         TR = TRICARE
+ ;          return value 0 if no data found, 1 if data found
+ ;
+ N TYPE,ECXPTYPE
+ ;Check input
+ Q:'$D(DFN) ""
+ S (TYPE,ECXPTYPE)=""
+ S TYPE=$G(^DPT(DFN,"TYPE"))
+ I 'TYPE Q ECXPTYPE
+ S ECXPTYPE=$P($G(^DG(391,TYPE,0)),U,1)
+ S ECXPTYPE=$E(ECXPTYPE,1,2)
+ Q ECXPTYPE
+CVEDT(DFN,DATE) ;Determine patient CV status DBIA #4156
+ ;   input
+ ;   DFN = patient ien
+ ;
+ ;   output
+ ;   ECXCVE = combat veteran status eligibility
+ ;   ECXCVEDT = combat veteran eligibility end date
+ ;   ECXCVENC = combat veteran encounter
+ ;Initialize variables
+ N CVSTAT
+ S (CVSTAT,ECXCVE,ECXCVEDT,ECXCVENC)=""
+ ;Check input
+ Q:'$D(DFN) 0
+ ;Call CV API
+ S CVSTAT=$$CVEDT^DGCV(DFN,DATE)
+ I CVSTAT<1 Q 0
+ ;Veteran been given CV eligibility
+ S ECXCVE=$S($P(CVSTAT,U,3)=1:"Y",$P(CVSTAT,U,3)=0:"E",1:"")
+ ;Save CV eligibility end date and convert from FM to HL7 format
+ S ECXCVEDT=$P(CVSTAT,U,2)
+ S ECXCVEDT=$$FMTHL7^XLFDT(ECXCVEDT)
+ ;Is the veteran eligible for CV in the date of encounter
+ S ECXCVENC=$S($P(CVSTAT,U,3)=1:"Y",1:"")
+ Q 1
+NPRF ;National patient record flags DBIA #3860
+ N ECXARR,FLG
+ S ECXNPRFI="",CNT=$$GETACT^DGPFAPI(ECXDFN,"ECXARR"),FLG=""
+ I 'CNT Q
+ F I=1:1:CNT D  Q:FLG
+ .I ECXARR(I,"CATEGORY")["NATIONAL" S ECXNPRFI="Y",FLG=1
+ Q
+RXPTST(K) ;Rx patient status DBIA #2511
+ N ECXDIC,STAT
+ S (ECXDIC,STAT)=""
+ ;Check input
+ Q:'$D(K) STAT
+ S DA=K,DIC="^PS(53,",DIQ(0)="I",DIQ="ECXDIC",DR="6"
+ D EN^DIQ1
+ S STAT=$G(ECXDIC(53,K,6,"I"))
+ S STAT=$S(STAT=1:"SC",STAT=2:"AA",STAT=3:"OTH",STAT=4:"INP",STAT=5:"NON",1:"")
+ Q STAT
+NONVAP(K) ;Non-va prescriber DBIA #10060
+ N ECXDIC,NONVAP
+ S (ECXDIC,NONVAP)=""
+ Q:'$D(K) NONVAP
+ S DA=K,DIC="^VA(200,",DIQ(0)="I",DIQ="ECXDIC",DR="53.91"
+ D EN^DIQ1
+ S NONVAP=$G(ECXDIC(200,K,53.91,"I"))
+ I NONVAP S NONVAP="Y"
+ Q NONVAP
+DOIVPO(K,L) ;Add destination for outpatient ivp orders
+ ;     Input     K - DFN
+ ;               L - Order # from Pharmacy Patient File (#55)
+ ;
+ ;     Output     ordering stop code
+ ;
+ N ECXDIC,ECXDICA,ECXDICB,DOIVPO,CLINIC,SCODE,DIC,DIQ,DR,DA
+ S (ECXDIC,ECXDICA,ECXDICB,DOIVPO,CLINIC,SCODE)=""
+ ;Check input
+ Q:'K!'(L) SCODE
+ ;Check treating specialty
+ S SCODE=$$TSSC($G(ECXTS)) I SCODE>0 Q SCODE
+ ;Go to pharmacy patient file (#55) and return value of field (#136)
+ S DIC=55,DIQ(0)="I",DIQ="ECXDIC",DR="100",DR(55.01)="136",DA=K,DA(55.01)=L
+ D EN^DIQ1
+ S CLINIC=$G(ECXDIC(55.01,L,136,"I"))
+ I 'CLINIC Q SCODE
+ ;Get stop code pointer to file 40.7 from file 44
+ S DIC="^SC(",DIQ(0)="I",DIQ="ECXDICA",DR="8",DA=CLINIC D EN^DIQ1
+ S SCODE=ECXDICA(44,CLINIC,8,"I")
+ ;Get stop code external value
+ S DIC="^DIC(40.7,",DIQ(0)="E",DIQ="ECXDICB",DR="1",DA=SCODE D EN^DIQ1
+ S SCODE=$G(ECXDICB(40.7,SCODE,1,"E"))
+ Q SCODE
+ ;
+DOUDO(K,L) ;Add destination for outpatient udp orders
+ ;     Input     K - DFN
+ ;               L - Order # from Pharmacy Patient File (#55)
+ ;
+ ;     Output     ordering stop code
+ ;
+ N ECXDIC,ECXDICA,ECXDICB,DOIVPO,CLINIC,SCODE,DIC,DIQ,DR,DA
+ S (ECXDIC,ECXDICA,ECXDICB,DOIVPO,CLINIC,SCODE)=""
+ ;Check treating specialty
+ S SCODE=$$TSSC($G(ECXTS)) I SCODE>0 Q SCODE
+ ;Check input
+ Q:'K!'(L) SCODE
+ S DIC=55,DIQ(0)="I",DIQ="ECXDIC",DR="62",DR(55.06)="130",DA=K,DA(55.06)=L
+ D EN^DIQ1
+ S CLINIC=$G(ECXDIC(55.06,L,130,"I"))
+ I 'CLINIC Q SCODE
+ ;Get stop code pointer to file 40.7 from file 44
+ S DIC="^SC(",DIQ(0)="I",DIQ="ECXDICA",DR="8",DA=CLINIC D EN^DIQ1
+ S SCODE=ECXDICA(44,CLINIC,8,"I")
+ ;Get stop code external value
+ S DIC="^DIC(40.7,",DIQ(0)="E",DIQ="ECXDICB",DR="1",DA=SCODE D EN^DIQ1
+ S SCODE=$G(ECXDICB(40.7,SCODE,1,"E"))
+ Q SCODE
+ ;
+PHAAPI(DRUG) ;Call Pharmacy drug file API dbia 4483
+ ;   Input: drug file (#50) ien
+ ;
+ ;   Output: generic name ^ classification ^ ndc ^ dea hand
+ ;            ^ ndf file entry # ^ psndf va product entry ^
+ ;            price per disp unit ^ dispense unit
+ ;
+ ;Initialize variables and scratch global
+ N NAME,CLASS,NDC,INV,NDF,P1,P3,PPDU,UNIT,ARRAY,DATA
+ S (NAME,CLASS,NDC,INV,NDF,P1,P3,PPDU,ARRAY,DATA)=""
+ S ARRAY="^TMP($J,""ECXLIST"")"
+ K @ARRAY
+ D DATA^PSS50(DRUG,,,,,"ECXLIST")
+ I @ARRAY@(0)'>0 Q "^^^^^^"
+ S NAME=@ARRAY@(DRUG,.01),CLASS=@ARRAY@(DRUG,2),NDC=@ARRAY@(DRUG,31)
+ S INV=@ARRAY@(DRUG,3),P1=$P(@ARRAY@(DRUG,20),U),P3=$P(@ARRAY@(DRUG,22),U),PPDU=@ARRAY@(DRUG,16),UNIT=@ARRAY@(DRUG,14.5)
+ K @ARRAY
+ Q NAME_U_CLASS_U_NDC_U_INV_U_P1_U_P3_U_PPDU_U_UNIT
+ ;
+TSSC(X) ;Check treating specialty (ts) and if ts equals any of the following
+ ;18,23,24,36,41,65,94 then assign predefined code and return value
+ ;
+ ;    Input: treating specialty
+ ;    Output: Ordering stop code
+ ;
+ S CODE=$S(X=18:293,X=23:295,X=24:290,X=36:294,X=41:296,X=65:291,X=94:292,1:"")
+ Q CODE
+ ;
+PSJ59P5(X) ;Get iv room division
+ ;   Input  X - iv room ien
+ ;
+ ;   Output - field .02 division
+ ;Init variables
+ N DIV S DIV=""
+ ;Check input
+ I 'X  Q DIV
+ D ALL^PSJ59P5(X,,"ECXDIV")
+ S DIV=$P($G(^TMP($J,"ECXDIV",X,.02)),U)
+ K ^TMP($J,"ECXDIV")
+ Q DIV
+ ;
+SCRX(IEN) ;Service connected prescription
+ ;Init variables
+ N DIC,DR,DA,ECXDIQ
+ ;Check input
+ I '$G(IEN) Q ""
+ S DIC=52,DR="116",DA=IEN,DIQ="ECXDIQ"
+ D DIQ^PSODI(DIC,DIC,DR,DA,DIQ)
+ Q $S($G(ECXDIQ(52,DA,116))="YES":"Y",$G(ECXDIQ(52,DA,116))="NO":"N",1:"")

WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXUTL6.m

@@ -1 @@
-ECXUTL6 ;ALB/JRC - Utilities for DSS Extracts ; 11/28/07 11:34am
-        ;;3.0;DSS EXTRACTS;**92,105**;Dec 22, 1997;Build 70
-        ;
-NUTKEY(P,D)     ;Generate n&fs feeder key
-        ;Required variables
-        ;      p  - diet type production diet, standing orders, supplemental
-        ;           feedings, or tube feedings.
-        ;      d  - diet ien from files 116.2, 118.3, 118, or 118.2
-        ;Check input
-        I $G(P)=""!'$G(D) Q ""
-        ;Init variables
-        N PRO,IENS,CODE,DIET
-        S (PRO,IENS,CODE,DIET)=0
-        S PRO=$O(^ECX(728.45,"B",P,PRO))
-        S CODE=D_$S(P="PD":";FH(116.2,",P="SO":";FH(118.3,",P="SF":";FH(118,",P="TF":";FH(118.2,",1:"")
-        S DIET=0,DIET=$O(^ECX(728.45,+PRO,1,"B",CODE,DIET))
-        S IENS=""_DIET_","_PRO_","_""
-        Q $$GET1^DIQ(728.451,IENS,1)
-        ;
-NUTLOC(P,D,FPD,FDD,FPF,DLT,DFL) ;Define nutrition fields
-        ;Required variables
-        ;      p  - patient status, inpatient or outpatient
-        ;
-        ;      d  - diet type production diet, standing orders, supplemental
-        ;            feedings, or tube feedings.
-        ;    Output: food production division, food delivery division, food
-        ;            production facility, food delivery type, delivery feeder
-        ;            location
-        ;Init variables
-        N WARD,TRSVP,CRSVP,OPLOC,MASWARD
-        S (CRSVP,TRSVP)=0,(WARD,DLT,DFL,MASWARD)=""
-        S OPLOC=""
-        ;Check input
-        I $G(P)=""!($G(D)="")!'($G(FHDFN)) Q ""
-        ;Get food production facility for inpatient, use 115.1.13 (dietetic
-        ;ward) field which points 119.6 (nutrition location), field 3 (tray
-        ;service point) or field 4 (cafeteria service point), which points to
-        ;119.72 (production facility) field 2.
-        I P="INP" D
-        .S WARD=$P($G(^FHPT(FHDFN,"A",+ECXADM,0)),U,8)
-        .S TRSVP=$$GET1^DIQ(119.6,WARD,3,"I")
-        .S CRSVP=$$GET1^DIQ(119.6,WARD,4,"I")
-        .;Get divisions
-        .D GETDIV
-        .Q
-        ;
-        ;Get food production facility for outpatient recurring meal, use
-        ;115.16.2 (outpatient location) which points to file 119.6 (nutrition
-        ;location) field 3 (tray service point) or field 4 (cafeteria service
-        ;point), which points to 119.72 (production facility) field 2.
-        I P["OP",D["RM" D
-        .S OPLOC=""_$P(NODE,U,3)_","_"",TRSVP=$$GET1^DIQ(119.6,OPLOC,3,"I")
-        .D GETDIV
-        .Q
-        ;
-        ;Get food production facility for outpatient tube feeding, use
-        ;115.16.2 (outpatient location) then use 119.6 nutrition location
-        ;which points to 119.72 field 2.
-        I P["OP",D["TF" D
-        .S OPLOC=""_$P(^TMP($J,"FH",DATE,FHDFN,NUMBER,"RM"),U,3)_","_""
-        .S TRSVP=$$GET1^DIQ(119.6,OPLOC,3,"I")
-        .;Get delivery division
-        .D GETDIV
-        .Q
-        ;
-        ;Get food production facility for special meals, use 115.17.2
-        ;location field 2 which is a pointer to 119.6 (nutrition location)
-        ;which points to 119.72 via field 2 (tray service point) which points
-        ;to file 119.71 (production facility) field 2.
-        I P["OP",D["SM" D
-        .S OPLOC=""_$P(NODE,U,3)_","_""
-        .S TRSVP=$$GET1^DIQ(119.6,OPLOC,3,"I")
-        .;Get delivery division
-        .D GETDIV
-        .Q
-        ;
-        ;Get food production facility for outpatient guest meals, use
-        ;115.18.4 (outpatient location) then use 119.6 nutrition location
-        ;which points to 119.72 (production facility) field 2.
-        I P["OP",D["GM" D
-        .S OPLOC=""_$P(NODE,U,5)_","_"",TRSVP=$$GET1^DIQ(119.6,OPLOC,3,"I")
-        .S FPF=$$GET1^DIQ(119.72,""_TRSVP_","_"",2,"I")
-        .;Get delivery division
-        .D GETDIV
-        .Q
-        ;
-        ;Get delivery location type for patients; with inpatients the type of
-        ;service needs to be pulled from the admission node, with outpatients
-        ;the type of service needs to be pulled from different nodes and use
-        ;field 101 of Nutrition Location file (#119.6). Delivery location
-        ;types only set for the following meals:
-        ;   Inpatient with a production diet
-        ;   Outpatient with a recurring meal
-        ;   Outpatient with a special meal
-        ;   Outpatient with a guest meal
-        ;   all other meals are null
-        I P="INP",D="PD" D
-        .S DLT=$P($G(NODE),U,8)
-        I P="OP",((D="RM")!(D="SM")) D
-        .S DLT=$E($$GET1^DIQ(119.6,""_$P(NODE,U,3)_","_"",101,"E"),1)
-        I P="OP",D="GM" D
-        .S DLT=$E($$GET1^DIQ(119.6,""_$P(NODE,U,5)_","_"",101,"E"),1)
-        ;
-        ;Delivery feeder location
-        I DLT="C" D
-        .S DFL=$E($$GET1^DIQ(119.6,WARD,4,"E"),1,10)
-        .S IEN=$$GET1^DIQ(119.72,+CRSVP,2,"I")
-        .S IEN=""_IEN_";FH(119.71,"
-        .S FPF=$O(^ECX(728.46,"B",IEN,FPF))
-        .S FPF=$E($$GET1^DIQ(728.46,FPF,.01,"E"),1,10)
-        I (DLT["T")!(DLT["D") D
-        .I P="INP" D
-        ..S MASWARD=$O(^FH(119.6,+WARD,"W","B",0))
-        ..S DFL=$$GET1^DIQ(42,+MASWARD,44,"I")
-        .I P="OP" D
-        ..S DFL=$O(^FH(119.6,+OPLOC,"L","B",0))
-        I (DLT=""),"SFTFSO"[D D
-        .S DFL=$S(TRSVP:$$GET1^DIQ(119.6,WARD,3,"E"),1:$$GET1^DIQ(119.6,WARD,4,"E"))
-        Q 1
-        ;
-GETDIV  ;Get divisions and food production facility
-        ;Init variables
-        N IEN,SIEN
-        S (FDD,FPF,FPD)=""
-        S IEN=$$GET1^DIQ(119.72,+TRSVP,2,"I")
-        Q:'IEN
-        ;Get delivery division
-        S SIEN=""_+TRSVP_";FH(119.72,"
-        S FDD=$O(^ECX(728.46,"B",SIEN,FDD))
-        S FDD=""_$$GET1^DIQ(728.46,FDD,1,"I")_","_""
-        S FDD=$$GET1^DIQ(4,FDD,99,"E")
-        ;Get production division and food production facility
-        S IEN=""_IEN_";FH(119.71,"
-        S FPF=$O(^ECX(728.46,"B",IEN,FPF))
-        S FPD=""_$$GET1^DIQ(728.46,FPF,1,"I")_","_""
-        S FPD=$$GET1^DIQ(4,FPD,99,"E")
-        S FPF=$E($$GET1^DIQ(728.46,FPF,.01,"E"),1,10)
-        Q
-        ;
-SUR(CRST,STCD,CLINIC)   ;Surgery stop codes and clinic (outpatients only)
-        ;Init variables
-        S (CRST,STCD,CLINIC)=""
-        ;Quit if not outpatient
-        Q:$P(EC0,U,12)'="O" ""
-        ;Get stop codes (outpatient only)
-        I $P(EC0,U,12)="O" D
-        .;Get credit stop code (outpatient only)
-        .S CRST=""_$$GET1^DIQ(40.7,""_$$GET1^DIQ(44,$$GET1^DIQ(137.45,$P(EC0,U,4),2,"I")_","_""_","_"",2503,"I")_","_"",1,"E")
-        .;Get stop code (outpatient only)
-        .S STCD=""_$$GET1^DIQ(40.7,""_$$GET1^DIQ(44,$$GET1^DIQ(137.45,$P(EC0,U,4),2,"I")_","_""_","_"",8,"I")_","_"",1,"E")
-        ;Clinic for non-or case use associated clinic else non-or location
-        ;If non-or case
-        I $P($G(ECNO),U)="Y" S CLINIC=$S($P(EC0,U,21):$P(EC0,U,21),1:$P(ECNO,U,2))
-        ;Get stop codes non-or cases
-        I $P($G(ECNO),U)="Y" D
-        .;Get credit stop code for non-or case
-        .S CRST=$$GET1^DIQ(40.7,$$GET1^DIQ(44,CLINIC,2503,"I"),1,"E")
-        .;Get stop code for non-or case
-        .S STCD=$$GET1^DIQ(40.7,$$GET1^DIQ(44,CLINIC,8,"I"),1,"E")
-        ;Clinic, not a non-or case use surgical specialty associated clinic
-        I $P($G(ECNO),U)'="Y" S CLINIC=$$GET1^DIQ(137.45,+$P(EC0,U,4),2,"I")
-        Q 1
-        ;
-SURPODX(PRODX,PODX1,PODX2,PODX3,PODX4,PODX5)    ;Get postop diagnosis codes
-        ;Init variables
-        N CODE,I,PODX
-        S (PRODX,PODX1,PODX2,PODX3,PODX4,PODX5)="",CODE=0
-        ;Check input
-        Q:'$D(DATAOP) 0
-        ;Get principal postop dx code
-        S PRODX=$$GET1^DIQ(80,$P(DATAOP,U,3),.01)
-        ;Get other postop dx codes
-        S (CODE,I)=0 F  S CODE=$O(^SRO(136,ECD0,4,CODE)) Q:'CODE  Q:I>5  D
-        .S I=I+1,PODX="PODX"_I,@PODX=$$GET1^DIQ(80,$P(^SRO(136,ECD0,4,CODE,0),U),.01)
-        Q 1
+ECXUTL6 ;ALB/JRC - Utilities for DSS Extracts ; 11/2/06 8:30am
+ ;;3.0;DSS EXTRACTS;**92**;Dec 22, 1997;Build 30
+ ;
+NUTKEY(P,D) ;Generate n&fs feeder key
+ ;Required variables
+ ;      p  - diet type production diet, standing orders, supplemental
+ ;           feedings, or tube feedings.
+ ;      d  - diet ien from files 116.2, 116.3, 118, or 118.2
+ ;Check input
+ I $G(P)=""!'$G(D) Q ""
+ ;Init variables
+ N PRO,IENS,CODE,DIET
+ S (PRO,IENS,CODE,DIET)=0
+ S PRO=$O(^ECX(728.45,"B",P,PRO))
+ S CODE=D_$S(P="PD":";FH(116.2,",P="SO":";FH(116.3,",P="SF":";FH(118,",P="TF":";FH(118.2,",1:"")
+ S DIET=0,DIET=$O(^ECX(728.45,+PRO,1,"B",CODE,DIET))
+ S IENS=""_DIET_","_PRO_","_""
+ Q $$GET1^DIQ(728.451,IENS,1)
+ ;
+NUTLOC(P,D,FPD,FDD,FPF,DLT,DFL) ;Define nutrition fields
+ ;Required variables
+ ;      p  - patient status, inpatient or outpatient
+ ;
+ ;      d  - diet type production diet, standing orders, supplemental
+ ;            feedings, or tube feedings.
+ ;    Output: food production division, food delivery division, food
+ ;            production facility, food delivery type, delivery feeder
+ ;            location
+ ;Init variables
+ N WARD,TRSVP,OPLOC,MASWARD
+ S TRSVP=0,(WARD,ECXDLT,ECXDFL,MASWARD)=""
+ S OPLOC=""
+ ;Check input
+ I $G(P)=""!($G(D)="")!'($G(FHDFN)) Q ""
+ ;Get food production facility for inpatient, use 115.1.13 (dietetic
+ ;ward) field which points 119.6 (nutrition location), field 3 (tray
+ ;service point) or field 4 (cafeteria service point), which points to
+ ;119.72 (production facility) field 2.
+ I P="INP" D
+ .S WARD=$P($G(^FHPT(FHDFN,"A",ECXADM,0)),U,8)
+ .S TRSVP=$$GET1^DIQ(119.6,WARD,3,"I")
+ .;Get divisions
+ .D GETDIV
+ .Q
+ ;
+ ;Get food production facility for outpatient recurring meal, use
+ ;115.16.2 (outpatient location) which points to file 119.6 (nutrition
+ ;location) field 3 (tray service point) or field 4 (cafeteria service
+ ;point), which points to 119.72 (production facility) field 2.
+ I P["OP",D["RM" D
+ .S OPLOC=""_$P(NODE,U,3)_","_"",TRSVP=$$GET1^DIQ(119.6,OPLOC,3,"I")
+ .D GETDIV
+ .Q
+ ;
+ ;Get food production facility for outpatient tube feeding, use
+ ;115.16.2 (outpatient location) then use 119.6 nutrition location
+ ;which points to 119.72 field 2.
+ I P["OP",D["TF" D
+ .S OPLOC=""_$P(^TMP($J,"FH",DATE,FHDFN,NUMBER,"RM"),U,3)_","_""
+ .S TRSVP=$$GET1^DIQ(119.6,OPLOC,3,"I")
+ .;Get delivery division
+ .D GETDIV
+ .Q
+ ;
+ ;Get food production facility for special meals, use 115.17.2
+ ;location field 2 which is a pointer to 119.6 (nutrition location)
+ ;which points to 119.72 via field 2 (tray service point) which points
+ ;to file 119.71 (production facility) field 2.
+ I P["OP",D["SM" D
+ .S OPLOC=""_$P(NODE,U,3)_","_""
+ .S TRSVP=$$GET1^DIQ(119.6,OPLOC,3,"I")
+ .;Get delivery division
+ .D GETDIV
+ .Q
+ ;
+ ;Get food production facility for outpatient guest meals, use
+ ;115.18.4 (outpatient location) then use 119.6 nutrition location
+ ;which points to 119.72 (production facility) field 2.
+ I P["OP",D["GM" D
+ .S OPLOC=""_$P(NODE,U,5)_","_"",TRSVP=$$GET1^DIQ(119.6,OPLOC,3,"I")
+ .S ECXFPF=$$GET1^DIQ(119.72,""_TRSVP_","_"",2,"I")
+ .;Get delivery division
+ .D GETDIV
+ .Q
+ ;
+ ;Get delivery location type for patients; with inpatients the type of
+ ;service needs to be pulled from the admission node, with outpatients
+ ;the type of service needs to be pulled from different nodes and use
+ ;field 101 of Nutrition Location file (#119.6). Delivery location
+ ;types only set for the following meals:
+ ;   Inpatient with a production diet
+ ;   Outpatient with a recurring meal
+ ;   Outpatient with a special meal
+ ;   Outpatient with a guest meal
+ ;   all other meals are null
+ I P="INP",D="PD" D
+ .S ECXDLT=$P($G(NODE),U,8)
+ I P="OP",((D="RM")!(D="SM")) D
+ .S ECXDLT=$E($$GET1^DIQ(119.6,""_$P(NODE,U,3)_","_"",101,"E"),1)
+ I P="OP",D="GM" D
+ .S ECXDLT=$E($$GET1^DIQ(119.6,""_$P(NODE,U,5)_","_"",101,"E"),1)
+ ;
+ ;Delivery feeder location
+ I ECXDLT="C" S ECXDFL=$P(NODE,U,8) D
+ .S ECXDFL=$E($$GET1^DIQ(119.72,ECXDFL,2,"E"),1,10)
+ I (ECXDLT["T")!(ECXDLT["D") D
+ .S MASWARD=$O(^FH(119.6,$S(WARD:+WARD,+OPLOC:+OPLOC,1:""),"W","B",0))
+ .S ECXDFL=$$GET1^DIQ(42,+MASWARD,44,"I")
+ Q 1
+ ;
+GETDIV ;Get divisions and food production facility
+ ;Init variables
+ N IEN,SIEN
+ S (ECXFDD,ECXFPF,ECXFPD)=""
+ S IEN=$$GET1^DIQ(119.72,+TRSVP,2,"I")
+ Q:'IEN
+ ;Get delivery division
+ S SIEN=""_+TRSVP_";FH(119.72,"
+ S ECXFDD=$O(^ECX(728.46,"B",SIEN,ECXFDD))
+ S ECXFDD=""_$$GET1^DIQ(728.46,ECXFDD,1,"I")_","_""
+ S ECXFDD=$$GET1^DIQ(4,ECXFDD,99,"E")
+ ;Get production division and food production facility
+ S IEN=""_IEN_";FH(119.71,"
+ S ECXFPF=$O(^ECX(728.46,"B",IEN,ECXFPF))
+ S ECXFPD=""_$$GET1^DIQ(728.46,ECXFPF,1,"I")_","_""
+ S ECXFPD=$$GET1^DIQ(4,ECXFPD,99,"E")
+ S ECXFPF=$E($$GET1^DIQ(728.46,ECXFPF,.01,"E"),1,10)
+ Q