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

BCHEXD2.m

Go to the documentation of this file. 
  1. BCHEXD2 ; IHS/CMI/LAB -PROCESS RECORD ; 
  1.  ;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
  1.  ;IHS/CMI/LAB - added $J to ^TMP
  1.  ;
  1.  ;Create export record.  68 characters in length.
  1.  ;
  1. RECORD ;EP
  1.  S (BCHE,BCHTX)=""
  1.  D ^BCHEXD21 ;IHS/CMI/LAB - new export format
  1.  Q  ;IHS/CMI/LAB - new export
  1. PROV ;get providers (1-4) 
  1.  I $P(BCHREC,U,3)="" S BCHE="E022" Q
  1.  S BCHAFF=$$PPAFFL^BCHUTIL(BCHR,"I") I BCHAFF=""!(BCHAFF["?") S BCHE="E023" Q
  1.  S BCHDISC=$$PPCLSC^BCHUTIL(BCHR) I BCHDISC=""!(BCHDISC["?") S BCHE="E024" Q
  1.  S BCHINI=$$PPINI^BCHUTIL(BCHR) I BCHINI["?" S BCHE="E025" Q
  1. PROV1 S X=BCHAFF_BCHDISC_BCHINI
  1.  S X=$$LBLK(X,6)
  1.  D TX
  1. PROG ;
  1.  S X=$P(BCHREC,U,2) I X]"" S X=$P(^BCHTPROG(X,0),U,5)
  1.  I X="" S X="-1"
  1.  S X=$$LBLK(X,7)
  1.  D TX
  1. DATE ;
  1.  S X=$P($P(BCHREC,U),".")
  1.  D TX
  1. FORM ;
  1.  S X=$P(BCHREC,U,25),X=$$LZERO(X,3) D TX
  1. ARN S X=BCHCPOV,X=$$LZERO(X,2) D TX
  1. RH S X=$P(BCHREC,U,26) S:X="" X="-" D TX
  1.  S X="  " D TX
  1. SC ;
  1.  S P=$P(^BCHRPROB(BCHPOVD,0),U,4),X=$S(P]"":$P(^BCHTSERV(P,0),U,3),1:" -")
  1.  S:X="" X=" -"
  1.  D TX
  1.  S X=" " D TX
  1. POV ;
  1.  S X=$P(^BCHRPROB(BCHPOVD,0),U),X=$P(^BCHTPROB(X,0),U,2)
  1.  S:X="" X="-1"
  1.  S:X="-" X=" -"
  1.  D TX
  1.  S X=" " D TX
  1. ACTL ;
  1.  S X=$P(BCHREC,U,6),X=$S(X]"":$P(^BCHTACTL(X,0),U,5),1:" -") S:X="-" X=" -" S:X="" X=" -" S:X="--" X=" -"
  1.  D TX
  1. NS ;
  1.  S X=$P(BCHREC,U,12) S:'X X=0 S X=$$LZERO(X,4)
  1.  D TX
  1. ST ;
  1.  S X=$P(^BCHRPROB(BCHPOVD,0),U,5) S:'X X=1 S X=$$LZERO(X,4)
  1.  D TX
  1. TT ;
  1.  I BCHCPOV=1 S X=$P(BCHREC,U,11) S:'X X=0 S X=$$LZERO(X,4)
  1.  E  S X="   0"
  1.  D TX
  1.  S X=" " D TX
  1. AGE ;
  1.  S X2=$P($G(^BCHR(BCHR,11)),U,2)
  1.  I X2]"" D  I 1
  1.  .S X1=$P($P(BCHREC,U),".") D ^%DTC S BCHAGE=X,BCHAGE=$J(BCHAGE/365.25,3,0) S X=$$LZERO(BCHAGE,3)
  1.  E  S X=" ",X=$$LBLK(X,3)
  1.  D TX
  1.  S X=" " D TX
  1. SEX ;
  1.  S X=$S($P($G(^BCHR(BCHR,11)),U,3)]"":$P($G(^BCHR(BCHR,11)),U,3),1:" ")
  1.  S X=$$LBLK(X,2)
  1.  D TX
  1.  S X=" " D TX
  1. REFF ;
  1.  S X="" I BCHCPOV=1 S X=$P(BCHREC,U,7) S:X'="" X=$P(^BCHTREF(X,0),U,3)
  1.  S:X="" X="  "
  1.  D TX
  1.  S X=" " D TX
  1. REFT ;
  1.  S X="" I BCHCPOV=1 S X=$P(BCHREC,U,8) S:X'="" X=$P(^BCHTREF(X,0),U,3)
  1.  S:X="" X="  "
  1.  D TX
  1.  S X=" " D TX
  1. SUB ;
  1.  S X=$P(^BCHRPROB(BCHPOVD,0),U,7)
  1.  S:X="" X=" "
  1.  D TX
  1.  S X=" " D TX
  1. EVAL ;
  1.  S X="" I BCHCPOV=1 S X=$P(BCHREC,U,9)
  1.  S:X="" X="  "
  1.  D TX
  1.  S X=" " D TX
  1. TYPE ;
  1.  S X="U"
  1.  D TX
  1.  Q
  1. TX ;EP
  1.  S BCHTX=BCHTX_X
  1.  Q
  1.  ;
  1. LZERO(V,L) ;EP - left zero fill
  1.  NEW %,I
  1.  S %=$L(V),Z=L-% F I=1:1:Z S V="0"_V
  1.  Q V
  1. LBLK(V,L) ;EP - left blank fill
  1.  NEW %,I
  1.  S %=$L(V),Z=L-% F I=1:1:Z S V=" "_V
  1.  Q V
  1. RBLK(V,L) ;right blank fill
  1.  NEW %,I
  1.  S %=$L(V),Z=L-% F I=1:1:Z S V=V_" "
  1.  Q V
  1. DELETES ;EP - called from BCHEXD , send delete txs
  1.  Q  ;IHS/CMI/LAB - new format
  1.  S BCH("CONTROL DATE")=BCH("RUN BEGIN")-1
  1.  F  S BCH("CONTROL DATE")=$O(^BCHEXDEL("AEX",BCH("CONTROL DATE"))) Q:BCH("CONTROL DATE")=""!(BCH("CONTROL DATE")>BCH("RUN END"))  D DELETES2 Q:BCH("QFLG")
  1.  Q
  1. DELETES2 ;
  1.  S BCHR="" F  S BCHR=$O(^BCHEXDEL("AEX",BCH("CONTROL DATE"),BCHR)) Q:BCHR=""  D DELETES3 Q:BCH("QFLG")
  1.  Q
  1. DELETES3 ;
  1.  S BCHTX=""
  1.  S BCHV("TX GENERATED")=0,^TMP("BCHDR",$J,"DELETES",BCH("CONTROL DATE"),BCHR)=BCH("MAIN TX DATE")
  1.  X BCHCNT
  1.  S X=$P(^BCHEXDEL(BCHR,0),U),X=$$LBLK(X,6) D TX
  1.  S X=$P(^BCHEXDEL(BCHR,0),U,2) S X=$$LBLK(X,7) D TX
  1.  S X=$P(^BCHEXDEL(BCHR,0),U,3) S X=$$LBLK(X,7) D TX
  1.  S X=$P(^BCHEXDEL(BCHR,0),U,4) S X=$$LZERO(X,3) D TX
  1.  S $E(BCHTX,68)=BCHRTYPE
  1.  D CNTBUILD^BCHEXD
  1.  K ^BCHEXDEL("AEX",BCH("CONTROL DATE"),BCHR)
  1.  Q
  1.  ;