Changeset 636 for FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXLBB.m

Timestamp:

Dec 4, 2009, 8:26:01 PM (14 years ago)

Author:

George Lilly

Message:

WorldVistAEHR overlayed on FOIAVistA

Location:

FOIAVistA/tag/r

Files:

• . (copied) (copied from FOIAVistA/trunk/r )
• DSS_EXTRACTS-ECX/ECXLBB.m (modified) (9 diffs)

FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXLBB.m

@@ -1 @@
-ECXLBB ;DALOI/KML - DSS BLOOD BANK EXTRACT ; 10/17/07 10:33am
- ;;3.0;DSS EXTRACTS;**78,84,90,92,104,105**;Dec 22, 1997;Build 70
+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 
@@ -12 +12 @@
 START ; Entry point from tasked job
  ; begin package specific extract
- N ECTRSP,ECADMT,ECTODT,ECENCTR,ECPAT,ECLRDFN,ECXPHY,ECXPHYPC,ECPHYNPI
+ 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 
@@ -37 +37 @@
  .; 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(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))
@@ -45 +45 @@
  . 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:"")
+ . S ECARRY(12)=$$UNITMOD(),ECARRY(11)=$S(ECARRY(12)'="":"Y",1:"N")
+ . S (ECXPHY,ECXPHYPC)=""
  . D GETDATA
  . K ECARRY
  Q
  ;
-UNITMODS() ; Get modification criteria from fields #.06 and #3 from file #66
+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"
@@ -58 +58 @@
  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,"^")))
+ 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^ECXLBB1($P(EC66A,"^")))
+ .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
  ;
-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")
- ;
+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
@@ -110 +97 @@
  . 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)
@@ -155 +140 @@
  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
+ .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
@@ -194 +179 @@
  ; 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
+ ; provider person class
  ;note:  DSS product dept and DSS IP # are dependent on the release of
  ; ECX*3*61
@@ -201 +185 @@
  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 ^ECX(ECFILE,EC7,0)=ECODE,ECRN=ECRN+1
  S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA
  Q