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

BCHEXD21.m

Go to the documentation of this file.
  1. BCHEXD21 ; IHS/CMI/LAB - new export format ;
  1. ;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
  1. ;IHS/CMI/LAB - added $J to ^TMP
  1. ;
  1. ;
  1. K BCH("POVS")
  1. D REC1
  1. D REC2
  1. K BCHREC,BCHY,BCHP,BCHPOV,X,BCHREC11,BCHREC12,BCHREC13,BCHREC21
  1. Q
  1. ;
  1. REC1 ;
  1. S BCHREC=^BCHR(BCHR,0),BCHREC11=$G(^BCHR(BCHR,11)),BCHREC12=$G(^BCHR(BCHR,12)),BCHREC13=$G(^BCHR(BCHR,13)),BCHREC21=$G(^BCHR(BCHR,21))
  1. F BCHY=1:1:62 S X="" D @BCHY S $P(BCHTX,U,BCHY)=X ;I BCHY=59!(BCHY=51)!(BCHY=52) W !,BCHY," ",X
  1. Q
  1. REC2 ;pov records
  1. S BCHP=0,C=0 F S BCHP=$O(^BCHRPROB("AD",BCHR,BCHP)) Q:BCHP'=+BCHP S BCHPOV=^BCHRPROB(BCHP,0),C=C+1 D
  1. .S BCH("POVS",C)=2_U_$P(^AUTTLOC(DUZ(2),0),U,10)_$$LZERO^BCHEXD2(BCHR,10)
  1. .S N=$P(BCHPOV,U,6) I N,$D(^AUTNPOV(N,0)) S N=$P(^AUTNPOV(N,0),U)
  1. .I N="" S N="NO NARRATIVE"
  1. .S BCH("POVS",C)=BCH("POVS",C)_U_$P(^BCHTPROB($P(BCHPOV,U),0),U,2)_U_$P(^BCHTSERV($P(BCHPOV,U,4),0),U,3)_U_$P(BCHPOV,U,5)_U_N_U_$P(BCHPOV,U,7)
  1. ;
  1. Q
  1. 1 ;record code
  1. S X=1
  1. Q
  1. 2 ;
  1. S X=$$UID(BCHR)_$$LZERO^BCHEXD2(BCHR,10)
  1. ;S X=$P(^AUTTLOC(DUZ(2),0),U,10)_$$LZERO^BCHEXD2(BCHR,10)
  1. Q
  1. 3 ;date of service
  1. S X=$$DATE($P($P(BCHREC,U),"."))
  1. Q
  1. 4 ;CHR Program
  1. I $P(BCHREC,U,2)="" S BCHE="E003" Q
  1. S X=$P(^BCHTPROG($P(BCHREC,U,2),0),U,5)
  1. Q
  1. 5 ;Chr provider name
  1. I $P(BCHREC,U,3)="" S BCHE="E002" Q
  1. S X=$P(^VA(200,$P(BCHREC,U,3),0),U)
  1. Q
  1. 6 ;chr provider code
  1. I $P(BCHREC,U,3)="" S BCHE="E022" Q
  1. S X=$P($G(^VA(200,$P(BCHREC,U,3),9999999)),U,9) Q
  1. 7 ;activity location
  1. I $P(BCHREC,U,6)="" S BCHE="E004" Q
  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="-" Q
  1. Q
  1. 8 ;location facility
  1. I $P(BCHREC,U,5)]"" S X=$P(^AUTTLOC($P(BCHREC,U,5),0),U,10) Q
  1. Q
  1. 9 ;referred to CHR by
  1. ;I $P(BCHREC,U,7)]"" S X=$P(^BCHTREF($P(BCHREC,U,7),0),U,3) Q
  1. S X=$O(^BCHR(BCHR,41,0)) Q:X="" S X=$P(^BCHR(BCHR,41,X,0),U,1) I X]"" S X=$P(^BCHTREF(X,0),U,3) Q
  1. Q
  1. 10 ;referred by CHR to
  1. ;I $P(BCHREC,U,8)]"" S X=$P(^BCHTREF($P(BCHREC,U,8),0),U,3) Q
  1. S X=$O(^BCHR(BCHR,42,0)) Q:X="" S X=$P(^BCHR(BCHR,42,X,0),U,1) I X]"" S X=$P(^BCHTREF(X,0),U,3) Q
  1. Q
  1. 11 ;travel time
  1. S X=$P(BCHREC,U,11) Q
  1. 12 ;number served
  1. S X=$P(BCHREC,U,12) Q
  1. 13 ;LMP
  1. S X=$$DATE($P(BCHREC,U,13)) Q
  1. 14 ;FMP
  1. I $P(BCHREC,U,14)]"" S X=$P(^BCHTFPM($P(BCHREC,U,14),0),U,2) Q
  1. Q
  1. 15 ;who entered record
  1. I $P(BCHREC,U,16)]"" S X=$P(^VA(200,$P(BCHREC,U,16),0),U) Q
  1. Q
  1. 16 ;date last updated
  1. S X=$$DATE($P(BCHREC,U,17)) Q
  1. 17 ;posting date
  1. S X=$$DATE($P(BCHREC,U,22)) Q
  1. 18 ;system of origin
  1. S X=$P(BCHREC,U,26) Q
  1. 19 ;total service time
  1. S X=$P(BCHREC,U,27) Q
  1. 20 ;temp res
  1. S X=$P(BCHREC11,U,8) Q
  1. 21 ;blood pressure
  1. S X=$P(BCHREC12,U) Q
  1. 22 ;weight
  1. S X=$P(BCHREC12,U,2) Q
  1. 23 ;height
  1. S X=$P(BCHREC12,U,3) Q
  1. 24 ;head
  1. S X=$P(BCHREC12,U,4) Q
  1. 25 ;vision corrected
  1. S X=$P(BCHREC12,U,6) Q
  1. 26 ;vision uncorrected
  1. S X=$P(BCHREC12,U,5) Q
  1. 27 ;tmp
  1. S X=$P(BCHREC12,U,7) Q
  1. 28 ;PULSE
  1. S X=$P(BCHREC12,U,8) Q
  1. 29 ;RESP
  1. S X=$P(BCHREC12,U,9) Q
  1. 30 ;PPD
  1. S X=$P(BCHREC12,U,10) Q
  1. 31 ;BS
  1. S X=$$DATE($P(BCHREC13,U,1)) Q
  1. 32 ;BS
  1. S X=$P(BCHREC13,U,2) Q
  1. 33 ;
  1. S X=$$DATE($P(BCHREC13,U,3)) Q
  1. 34 ;TC
  1. S X=$P(BCHREC13,U,4) Q
  1. 35 ;
  1. S X=$$DATE($P(BCHREC13,U,5)) Q
  1. 36 ;UA
  1. S X=$P(BCHREC13,U,6) Q
  1. 37 ;
  1. S X=$$DATE($P(BCHREC13,U,7)) Q
  1. 38 ;
  1. S X=$P(BCHREC13,U,8) Q
  1. 39 ;
  1. S X=$P(BCHREC21,U) Q
  1. 40 ;
  1. S X=$P(BCHREC21,U,2) Q
  1. 41 ;
  1. S X=$P(BCHREC11,U) Q
  1. 42 ;
  1. S X=$P(BCHREC11,U,3) Q
  1. 43 ;
  1. S X=$$DATE($P(BCHREC11,U,2)) Q
  1. 44 ;
  1. S X=$P(BCHREC11,U,4) Q
  1. 45 ;tribe
  1. I $P(BCHREC11,U,5)]"" S X=$P(^AUTTTRI($P(BCHREC11,U,5),0),U,2) Q
  1. Q
  1. 46 ;community
  1. I $P(BCHREC11,U,6)]"" S X=$P(^AUTTCOM($P(BCHREC11,U,6),0),U,8) Q
  1. Q
  1. 47 ;evaluation
  1. S X=$P(BCHREC,U,9) Q
  1. 48 ;
  1. I $P(BCHREC11,U,9)]"",$P(BCHREC11,U,11)]"" S X=$P(^AUTTLOC($P(BCHREC11,U,9),0),U,10)_$$LZERO^BCHEXD2($P(BCHREC11,U,11),6) Q
  1. 49 ;unique id 1
  1. S X=$P($G(^BCHR(BCHR,14)),U)
  1. Q
  1. 50 ;unique id2
  1. S X=$P($G(^BCHR(BCHR,14)),U,2)
  1. Q
  1. 51 ;
  1. S X="",(C,Y)=0 F S Y=$O(^BCHR(BCHR,41,Y)) Q:Y'=+Y S C=C+1 I C=2 S X=$P(^BCHR(BCHR,41,Y,0),U,1) I X]"" S X=$P(^BCHTREF(X,0),U,3)
  1. Q
  1. 52 ;
  1. S X="",(C,Y)=0 F S Y=$O(^BCHR(BCHR,41,Y)) Q:Y'=+Y S C=C+1 I C=3 S X=$P(^BCHR(BCHR,41,Y,0),U,1) I X]"" S X=$P(^BCHTREF(X,0),U,3)
  1. Q
  1. 53 ;
  1. S X="",(C,Y)=0 F S Y=$O(^BCHR(BCHR,41,Y)) Q:Y'=+Y S C=C+1 I C=4 S X=$P(^BCHR(BCHR,41,Y,0),U,1) I X]"" S X=$P(^BCHTREF(X,0),U,3)
  1. Q
  1. 54 ;
  1. S X="",(C,Y)=0 F S Y=$O(^BCHR(BCHR,41,Y)) Q:Y'=+Y S C=C+1 I C=5 S X=$P(^BCHR(BCHR,41,Y,0),U,1) I X]"" S X=$P(^BCHTREF(X,0),U,3)
  1. Q
  1. 55 ;
  1. S X="",(C,Y)=0 F S Y=$O(^BCHR(BCHR,42,Y)) Q:Y'=+Y S C=C+1 I C=2 S X=$P(^BCHR(BCHR,42,Y,0),U,1) I X]"" S X=$P(^BCHTREF(X,0),U,3)
  1. Q
  1. 56 ;
  1. S X="",(C,Y)=0 F S Y=$O(^BCHR(BCHR,42,Y)) Q:Y'=+Y S C=C+1 I C=3 S X=$P(^BCHR(BCHR,42,Y,0),U,1) I X]"" S X=$P(^BCHTREF(X,0),U,3)
  1. Q
  1. 57 ;
  1. S X="",(C,Y)=0 F S Y=$O(^BCHR(BCHR,42,Y)) Q:Y'=+Y S C=C+1 I C=4 S X=$P(^BCHR(BCHR,42,Y,0),U,1) I X]"" S X=$P(^BCHTREF(X,0),U,3)
  1. Q
  1. 58 ;
  1. S X="",(C,Y)=0 F S Y=$O(^BCHR(BCHR,42,Y)) Q:Y'=+Y S C=C+1 I C=5 S X=$P(^BCHR(BCHR,42,Y,0),U,1) I X]"" S X=$P(^BCHTREF(X,0),U,3)
  1. Q
  1. 59 ;
  1. S X=$P(BCHREC,U,29)
  1. Q
  1. 60 ;
  1. S X=$$VAL^XBDIQ1(90002,BCHR,1501)
  1. Q
  1. 61 ;
  1. S X=$$VAL^XBDIQ1(90002,BCHR,1502)
  1. Q
  1. 62 ;
  1. S X=$$VALI^XBDIQ1(90002,BCHR,1503)
  1. I X="" Q
  1. S X=$P($G(^DIC(5,X,0)),U,2)
  1. Q
  1. ;
  1. DATE(X) ;EP
  1. I X="" Q ""
  1. Q $E(X,4,5)_$E(X,6,7)_(1700+($E(X,1,3)))
  1. UID(REC) ;EP - generate unique ID for record
  1. I '$G(REC) Q REC
  1. NEW X
  1. ;I '$P($G(^AUTTSITE(1,1)),"^",3) S $P(^AUTTSITE(1,1),"^",3)=$P(^AUTTLOC($P(^AUTTSITE(1,0),"^",1),0),"^",10)
  1. ;Q $P(^AUTTSITE(1,1),"^",3)
  1. Q $P($G(^AUTTLOC(DUZ(2),0)),U,10)