Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BHLOBRI

BHLOBRI.m

Go to the documentation of this file. 
  1. BHLOBRI ; cmi/sitka/maw - File Inbound OBR Segment ; 
  1.  ;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
  1.  ;
  1.  ;this routine will file the inbound OBR segment it will then call
  1.  ;the corresponding entry point to file the OBX segment (result)
  1.  ;
  1.  ;
  1. MAIN ;-- this is the main routine driver
  1.  S BHLODA=0 F  S BHLODA=$O(@BHLTMP@(BHLODA)) Q:BHLODA=""  D
  1.  . S BHLVFL=$P($G(@BHLTMP@(BHLODA,3)),CS,3)
  1.  . Q:BHLVFL=""
  1.  . Q:'$L($T(@BHLVFL))
  1.  . S BHLPAR=BHLODA
  1.  . D @BHLVFL
  1.  D EOJ
  1.  Q
  1.  ;
  1. MSR ;-- this is the v measurement file           
  1.  X BHLKW
  1.  K BHLMTCH
  1.  S BHLTP=$P($G(@BHLTMP@(BHLODA,4)),CS,4)
  1.  Q:BHLTP=""
  1.  I '$O(^AUTTMSR("B",BHLTP,0)) S BHLERCD="NOMSR" X BHLERR Q
  1.  S BHLTPI=$O(^AUTTMSR("B",BHLTP,0))
  1.  S BHLDA=0 F  S BHLDA=$O(^AUPNVMSR("AD",BHLVSIT,BHLDA)) Q:BHLDA=""!($D(BHLMTCH))  D
  1.  . I $P(^AUPNVMSR(BHLDA,0),U)=BHLTPI S BHLMTCH=1
  1.  Q:$D(BHLMTCH)
  1.  D @BHLVFL^BHLOBXI
  1.  Q
  1.  ;
  1. EYE ;-- this is the v eye glass file
  1.  X BHLKW
  1.  D @BHLVFL^BHLOBXI
  1.  Q
  1.  ;
  1. LAB ;-- this is the v lab file
  1.  X BHLKW
  1.  K BHLMTCH
  1.  S BHLLB=$P($G(@BHLTMP@(BHLODA,4)),CS,4)
  1.  Q:BHLLB=""
  1.  I '$O(^LAB(60,"B",BHLLB,0)) S BHLERCD="NOLAB" X BHLERR Q
  1.  S BHLLBI=$O(^LAB(60,"B",BHLLB,0))
  1.  S BHLDA=0 F  S BHLDA=$O(^AUPNVLAB("AD",BHLVSIT,BHLDA)) Q:BHLDA=""!($D(BHLMTCH))  D
  1.  . I $P(^AUPNVLAB(BHLDA,0),U)=BHLLBI S BHLMTCH=1
  1.  Q:$D(BHLMTCH)
  1.  S BHLSITE=$G(@BHLTMP@(BHLODA,15))
  1.  I BHLSITE'="" D
  1.  . I '$O(^LAB(61,"B",BHLSITE,0)) S BHLERCD="NOLSITE" X BHLERR Q
  1.  . S BHLSITEI=$O(^LAB(61,"B",BHLSITE,0))
  1.  S BHLOP=$P($G(@BHLTMP@(BHLODA,16)),CS,2)
  1.  X BHLKSV
  1.  S APCDALVR("APCDTSTE")=BHLSITE
  1.  S APCDALVR("APCDTPRV")=BHLOP
  1.  D @BHLVFL^BHLOBXI
  1.  Q
  1.  ;
  1. SK ;-- this is the v skin test file
  1.  X BHLKW
  1.  K BHLMTCH
  1.  S BHLSK=$P($G(@BHLTMP@(BHLODA,4)),CS,5)
  1.  Q:BHLSK=""
  1.  I '$O(^AUTTSK("B",BHLSK,0)) S BHLERCD="NOSK" X BHLERR Q
  1.  S BHLSKI=$O(^AUTTSK("B",BHLSK,0))
  1.  S BHLOSD=$G(@BHLTMP@(BHLODA,7))
  1.  S BHLOED=$G(@BHLTMP@(BHLODA,8))
  1.  S BHLDA=0 F  S BHLDA=$O(^AUPNVSK("AD",BHLVSIT,BHLDA)) Q:BHLDA=""!$D(BHLERR("WARNING"))  D
  1.  . I $P(^AUPNVSK(BHLDA,0),U)=BHLSKI S BHLMTCH=1
  1.  I '$D(BHLMTCH) D
  1.  . X BHLKSV
  1.  . S APCDALVR("APCDATMP")="[APCDALVR 9000010.12 (ADD)]"
  1.  . S APCDALVR("APCDTSK")=BHLSK
  1.  . S APCDALVR("APCDTCDT")=BHLOSD
  1.  . S APCDALVR("APCDTDR")=BHLOED
  1.  . D ^APCDALVR
  1.  . I $D(APCDALVR("APCDAFLG")) S BHLERCD="NOVSK" X BHLERR Q
  1.  D @BHLVFL^BHLOBXI
  1.  Q
  1.  ;
  1. XAM ;-- this is the v exam file
  1.  X BHLKW
  1.  K BHLMTCH
  1.  S BHLXM=$P($G(@BHLTMP@(BHLODA,4)),CS,4)
  1.  Q:BHLXM=""
  1.  I '$O(^AUTTEXAM("B",BHLXM,0)) S BHLERCD="NOXAM" X BHLERR Q
  1.  S BHLXMI=$O(^AUTTEXAM("B",BHLXM,0))
  1.  S BHLDA=0 F  S BHLDA=$O(^AUPNVXAM("AD",BHLVSIT,BHLDA)) Q:BHLDA=""!($D(BHLMTCH))  D
  1.  . I $P(^AUPNVXAM(BHLDA,0),U)=BHLXMI S BHLMTCH=1
  1.  Q:$D(BHLMTCH)
  1.  X BHLKSV
  1.  S APCDALVR("APCDATMP")="[APCDALVR 9000010.13 (ADD)]"
  1.  S APCDALVR("APCDTEX")=BHLXM
  1.  D @BHLVFL^BHLOBXI
  1.  Q
  1.  ;
  1. TRT ;-- this is the v treatment file
  1.  X BHLKW
  1.  K BHLMTCH
  1.  S BHLTRT=$P($G(@BHLTMP@(BHLODA,4)),CS,4)
  1.  Q:BHLTRT=""
  1.  I '$O(^AUTTTRT("B",BHLTRT,0)) S BHLERCD="NOTRT" X BHLERR Q
  1.  S BHLTRTI=$O(^AUTTTRT("B",BHLTRT,0))
  1.  S BHLDA=0 F  S BHLDA=$O(^AUPNVTRT("AD",BHLVSIT,BHLDA)) Q:BHLDA=""!($D(BHLMTCH))  D
  1.  . I $P(^AUPNVTRT(BHLDA,0),U)=BHLTRTI S BHLMTCH=1
  1.  Q:$D(BHLMTCH)
  1.  X BHLKSV
  1.  S APCDALVR("APCDATMP")="[APCDALVR 9000010.15 (ADD)]"
  1.  S APCDALVR("APCDTTRT")="`"_BHLTRTI
  1.  D @BHLVFL^BHLOBXI
  1.  Q
  1.  ;
  1. PED ;-- this is the v patient ed file
  1.  X BHLKW
  1.  K BHLMTCH
  1.  S BHLED=$P($G(@BHLTMP@(BHLODA,4)),CS,4)
  1.  S BHLEDC=$P($G(@BHLTMP@(BHLODA,4)),CS,5)
  1.  Q:BHLED=""
  1.  I '$O(^AUTTEDT("B",BHLED,0)) S BHLERCD="NOPED" X BHLERR Q
  1.  S BHLEDI=$O(^AUTTEDT("B",BHLED,0))
  1.  S BHLDA=0 F  S BHLDA=$O(^AUPNVPED("AD",BHLVSIT,BHLDA)) Q:BHLDA=""!($D(BHLMTCH))  D
  1.  . I $P(^AUPNVPED(BHLDA,0),U)=BHLEDI S BHLMTCH=1
  1.  Q:$D(BHLMTCH)
  1.  X BHLKSV
  1.  S APCDALVR("APCDATMP")="[APCDALVR 9000010.16 (ADD)]"
  1.  S APCDALVR("APCDTTOP")=BHLED
  1.  D @BHLVFL^BHLOBXI
  1.  Q
  1.  ;
  1. PT ;-- this is the v physical therapy file
  1.  X BHLKW
  1.  K BHLMTCH
  1.  S BHLPT=$P($G(@BHLTMP@(BHLODA,4)),CS,4)
  1.  Q:BHLPT=""
  1.  I '$O(^AUTTPHTH("B",BHLPT,0)) S BHLERCD="NOPT" X BHLERR Q
  1.  S BHLPTI=$O(^AUTTPHTH("B",BHLPT,0))
  1.  S BHLDA=0 F  S BHLDA=$O(^AUPNVPT("AD",BHLVSIT,BHLDA)) Q:BHLDA=""!($D(BHLMTCH))  D
  1.  . I $P(^AUPNVPT(BHLDA,0),U)=BHLPTI S BHLMTCH=1
  1.  Q:$D(BHLMTCH)
  1.  X BHLKSV
  1.  S APCDALVR("APCDATMP")="[APCDALVR 9000010.17 (ADD)]"
  1.  S APCDALVR("APCDTCOD")=BHLPT
  1.  D @BHLVFL^BHLOBXI
  1.  Q
  1.  ;
  1. CPT ;-- this is the v cpt file
  1.  X BHLKW
  1.  K BHLMTCH
  1.  S BHLC=$P($G(@BHLTMP@(BHLODA,4)),CS,4)
  1.  Q:BHLC=""
  1.  I '$O(^ICPT("B",BHLC,0)) S BHLERCD="NOCPT" X BHLERR Q
  1.  S BHLCI=$O(^ICPT("B",BHLC,0))
  1.  S BHLDA=0 F  S BHLDA=$O(^AUPNVCPT("AD",BHLVSIT,BHLDA)) Q:BHLDA=""!($D(BHLMTCH))  D
  1.  . I $P(^AUPNVCPT(BHLDA,0),U)=BHLCI S BHLMTCH=1
  1.  Q:$D(BHLMTCH)
  1.  X BHLKSV
  1.  S APCDALVR("APCDATMP")="[APCDALVR 9000010.18 (ADD)]"
  1.  S APCDALVR("APCDTCPT")=BHLC
  1.  D @BHLVFL^BHLOBXI
  1.  Q
  1.  ;
  1. DXP ;-- this is the v diagnostic procedure file
  1.  X BHLKW
  1.  K BHLMTCH
  1.  S BHLDXP=$P($G(@BHLTMP@(BHLODA,4)),CS,4)
  1.  Q:BHLDXP=""
  1.  I '$O(^AUTTDXPR("B",BHLDXP,0)) S BHLERCD="NODXP" X BHLERR Q
  1.  S BHLDXPI=$O(^AUTTDXPR("B",BHLDXP,0))
  1.  S BHLPRV=$P($G(@BHLTMP@(BHLODA,16)),CS,2)
  1.  S BHLDA=0 F  S BHLDA=$O(^AUPNVDXP("AD",BHLVSIT,BHLDA)) Q:BHLDA=""!$D(BHLERR("WARNING"))  D
  1.  . I $P(^AUPNVDXP(BHLDA,0),U)=BHLDXPI S BHLMTCH=1
  1.  I '$D(BHLMTCH) D
  1.  . X BHLKSV
  1.  . S APCDALVR("APCDATMP")="[APCDALVR 9000010.21 (ADD)]"
  1.  . S APCDALVR("APCDTDXR")=BHLDXP
  1.  . S APCDALVR("APCDTPRV")=BHLPRV
  1.  . D ^APCDALVR
  1.  . I $D(APCDALVR("APCDAFLG")) S BHLERCD="NOVDXP" X BHLERR Q
  1.  D @BHLVFL^BHLOBXI
  1.  Q
  1.  ;
  1. RAD ;-- this is the v radiology file
  1.  X BHLKW
  1.  K BHLMTCH
  1.  S BHLIMP=$P($G(@BHLTMP@(BHLODA,4)),CS,4)
  1.  Q:BHLIMP=""
  1.  I '$O(^RAMIS(71,"B",BHLIMP,0)) S BHLERCD="NORAD" X BHLERR Q
  1.  S BHLIMPI=$O(^RAMIS(71,"B",BHLIMP,0))
  1.  S BHLDA=0 F  S BHLDA=$O(^AUPNVRAD("AD",BHLVSIT,BHLDA)) Q:BHLDA=""!($D(BHLMTCH))  D
  1.  . I $P(^AUPNVRAD(BHLDA,0),U)=BHLIMPI S BHLMTCH=1
  1.  Q:$D(BHLMTCH)
  1.  S BHLPRV=$P($G(@BHLTMP@(BHLODA,16)),CS,2)
  1.  X BHLKSV
  1.  S APCDALVR("APCDATMP")="[APCDALVR 9000010.22 (ADD)]"
  1.  S APCDALVR("APCDTRAD")=BHLIMP
  1.  D @BHLVFL^BHLOBXI
  1.  Q
  1.  ;
  1. HF ;-- this is the v health factors file
  1.  X BHLKW
  1.  K BHLMTCH
  1.  S BHLHF=$P($G(@BHLTMP@(BHLODA,4)),CS,4)
  1.  Q:BHLHF=""
  1.  I '$O(^AUTTHF("B",BHLHF,0)) S BHLERCD="NOHF" X BHLERR Q
  1.  S BHLHFI=$O(^AUTTHF("B",BHLHF,0))
  1.  S BHLDA=0 F  S BHLDA=$O(^AUPNVHF("AD",BHLVSIT,BHLDA)) Q:BHLDA=""!$D(BHLERR("WARNING"))  D
  1.  . I $P(^AUPNVHF(BHLDA,0),U)=BHLHFI S BHLMTCH=1
  1.  I '$D(BHLMTCH) D
  1.  . X BHLKSV
  1.  . S APCDALVR("APCDATMP")="[APCDALVR 9000010.23 (ADD)]"
  1.  . S APCDALVR("APCDTHF")=BHLHF
  1.  . D ^APCDALVR
  1.  . I $D(APCDALVR("APCDAFLG")) S BHLERCD="NOVHF" X BHLERR Q
  1.  D @BHLVFL^BHLOBXI
  1.  Q
  1.  ;
  1. EOJ ;-- kill variables
  1.  K @BHLTMP
  1.  K BHLDA,BHLVFL,BHLMTCH,BHLTP,BHLTPI,BHLLB,BHLLBI,BHLSITE,BHLOP
  1.  K BHLSK,BHLOSD,BHLOED,BHLXM,BHLTRT,BHLED,BHLPT,BHLC,BHLDXP,BHLPRV
  1.  K BHLIMP,BHLHF,BHLVL,BHLVIEN,BHLFL,BHLFLD,BHLX,BHLUT,BHLRL,BHLRH
  1.  K BHLSITEI,BHLABN,BHLUP,BHLEDT,BHLVAL,BHLTPI,BHLLBI,BHLSKI,BHLXMI
  1.  K BHLTRTI,BHLEDI,BHLPTI,BHLCI,BHLDXPI,BHLIMPI,BHLHFI
  1.  Q
  1.  ;