- 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)