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