- BGP0POS2 ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 28 Jan 2005 1:34 PM ;
- ;;10.0;IHS CLINICAL REPORTING;;JUN 18, 2010
- ;
- ;
- PRE ;EP
- ;CHANGE PACKAGE FILE NAME
- S BGPX=0 F S BGPX=$O(^BGPPEIT(BGPX)) Q:BGPX'=+BGPX S DA=BGPX,DIK="^BGPPEIT(" D ^DIK
- S BGPX=0 F S BGPX=$O(^BGPELIT(BGPX)) Q:BGPX'=+BGPX S DA=BGPX,DIK="^BGPELIT(" D ^DIK
- S BGPX=0 F S BGPX=$O(^BGPELIIT(BGPX)) Q:BGPX'=+BGPX S DA=BGPX,DIK="^BGPELIIT(" D ^DIK
- S BGPX=0 F S BGPX=$O(^BGPCMSIT(BGPX)) Q:BGPX'=+BGPX S DA=BGPX,DIK="^BGPCMSIT(" D ^DIK
- S BGPX=0 F S BGPX=$O(^BGPNPLT(BGPX)) Q:BGPX'=+BGPX S DA=BGPX,DIK="^BGPNPLT(" D ^DIK
- S BGPX=0 F S BGPX=$O(^BGPHEIT(BGPX)) Q:BGPX'=+BGPX S DA=BGPX,DIK="^BGPHEIT(" D ^DIK
- S BGPX=0 F S BGPX=$O(^BGPHEIIT(BGPX)) Q:BGPX'=+BGPX S DA=BGPX,DIK="^BGPHEIIT(" D ^DIK
- S BGPX=0 F S BGPX=$O(^BGPINDTC(BGPX)) Q:BGPX'=+BGPX S DA=BGPX,DIK="^BGPINDTC(" D ^DIK
- S BGPX=0 F S BGPX=$O(^BGPINDT(BGPX)) Q:BGPX'=+BGPX S DA=BGPX,DIK="^BGPINDT(" D ^DIK
- S BGPX=0 F S BGPX=$O(^BGPTAXT(BGPX)) Q:BGPX'=+BGPX S DA=BGPX,DIK="^BGPTAXT(" D ^DIK
- S BGPX=0 F S BGPX=$O(^BGPCMSMT(BGPX)) Q:BGPX'=+BGPX S DA=BGPX,DIK="^BGPCMSMT(" D ^DIK
- S BGPX=0 F S BGPX=$O(^BGPSCAT(BGPX)) Q:BGPX'=+BGPX S DA=BGPX,DIK="^BGPSCAT(" D ^DIK
- S BGPX=0 F S BGPX=$O(^BGPICAGT(BGPX)) Q:BGPX'=+BGPX S DA=BGPX,DIK="^BGPICAGT(" D ^DIK
- S BGPX=0 F S BGPX=$O(^BGPICACT(BGPX)) Q:BGPX'=+BGPX S DA=BGPX,DIK="^BGPICACT(" D ^DIK
- F BGPX=0 F S BGPX=$O(^BGPEOMT(BGPX)) Q:BGPX'=+BGPX S DA=BGPX,DIK="^BGPEOMT(" D ^DIK
- S BGPX=0 F S BGPX=$O(^BGPEOMIT(BGPX)) Q:BGPX'=+BGPX S DA=BGPX,DIK="^BGPEOMIT(" D ^DIK
- F BGPX=1:1:2000 K ^BGPTAXT(BGPX)
- S BGPX=0 F S BGPX=$O(^BGPTAXTT(BGPX)) Q:BGPX'=+BGPX S DA=BGPX,DIK="^BGPTAXTT(" D ^DIK
- F BGPX=1:1:2000 K ^BGPTAXTT(BGPX)
- S X=0 F S X=$O(^BGPSITE(X)) Q:X'=+X S $P(^BGPSITE(X,0),U,3)=""
- S X=0 F S X=$O(^ATXAX(X)) Q:X'=+X D
- .I $D(^ATXAX(X,21,0)),$P(^ATXAX(X,21,0),U,2)'["9002226.02101A" S $P(^ATXAX(X,21,0),U,2)="9002226.02101A"
- .I $D(^ATXAX(X,41,0)),$P(^ATXAX(X,41,0),U,2)'["9002226.04101P" S $P(^ATXAX(X,41,0),U,2)="9002226.04101P"
- K ATXFLG
- Q
- BGP0POS2 ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 28 Jan 2005 1:34 PM ;
- +1 ;;10.0;IHS CLINICAL REPORTING;;JUN 18, 2010
- +2 ;
- +3 ;
- PRE ;EP
- +1 ;CHANGE PACKAGE FILE NAME
- +2 SET BGPX=0
- FOR
- SET BGPX=$ORDER(^BGPPEIT(BGPX))
- IF BGPX'=+BGPX
- QUIT
- SET DA=BGPX
- SET DIK="^BGPPEIT("
- DO ^DIK
- +3 SET BGPX=0
- FOR
- SET BGPX=$ORDER(^BGPELIT(BGPX))
- IF BGPX'=+BGPX
- QUIT
- SET DA=BGPX
- SET DIK="^BGPELIT("
- DO ^DIK
- +4 SET BGPX=0
- FOR
- SET BGPX=$ORDER(^BGPELIIT(BGPX))
- IF BGPX'=+BGPX
- QUIT
- SET DA=BGPX
- SET DIK="^BGPELIIT("
- DO ^DIK
- +5 SET BGPX=0
- FOR
- SET BGPX=$ORDER(^BGPCMSIT(BGPX))
- IF BGPX'=+BGPX
- QUIT
- SET DA=BGPX
- SET DIK="^BGPCMSIT("
- DO ^DIK
- +6 SET BGPX=0
- FOR
- SET BGPX=$ORDER(^BGPNPLT(BGPX))
- IF BGPX'=+BGPX
- QUIT
- SET DA=BGPX
- SET DIK="^BGPNPLT("
- DO ^DIK
- +7 SET BGPX=0
- FOR
- SET BGPX=$ORDER(^BGPHEIT(BGPX))
- IF BGPX'=+BGPX
- QUIT
- SET DA=BGPX
- SET DIK="^BGPHEIT("
- DO ^DIK
- +8 SET BGPX=0
- FOR
- SET BGPX=$ORDER(^BGPHEIIT(BGPX))
- IF BGPX'=+BGPX
- QUIT
- SET DA=BGPX
- SET DIK="^BGPHEIIT("
- DO ^DIK
- +9 SET BGPX=0
- FOR
- SET BGPX=$ORDER(^BGPINDTC(BGPX))
- IF BGPX'=+BGPX
- QUIT
- SET DA=BGPX
- SET DIK="^BGPINDTC("
- DO ^DIK
- +10 SET BGPX=0
- FOR
- SET BGPX=$ORDER(^BGPINDT(BGPX))
- IF BGPX'=+BGPX
- QUIT
- SET DA=BGPX
- SET DIK="^BGPINDT("
- DO ^DIK
- +11 SET BGPX=0
- FOR
- SET BGPX=$ORDER(^BGPTAXT(BGPX))
- IF BGPX'=+BGPX
- QUIT
- SET DA=BGPX
- SET DIK="^BGPTAXT("
- DO ^DIK
- +12 SET BGPX=0
- FOR
- SET BGPX=$ORDER(^BGPCMSMT(BGPX))
- IF BGPX'=+BGPX
- QUIT
- SET DA=BGPX
- SET DIK="^BGPCMSMT("
- DO ^DIK
- +13 SET BGPX=0
- FOR
- SET BGPX=$ORDER(^BGPSCAT(BGPX))
- IF BGPX'=+BGPX
- QUIT
- SET DA=BGPX
- SET DIK="^BGPSCAT("
- DO ^DIK
- +14 SET BGPX=0
- FOR
- SET BGPX=$ORDER(^BGPICAGT(BGPX))
- IF BGPX'=+BGPX
- QUIT
- SET DA=BGPX
- SET DIK="^BGPICAGT("
- DO ^DIK
- +15 SET BGPX=0
- FOR
- SET BGPX=$ORDER(^BGPICACT(BGPX))
- IF BGPX'=+BGPX
- QUIT
- SET DA=BGPX
- SET DIK="^BGPICACT("
- DO ^DIK
- +16 FOR BGPX=0
- FOR
- SET BGPX=$ORDER(^BGPEOMT(BGPX))
- IF BGPX'=+BGPX
- QUIT
- SET DA=BGPX
- SET DIK="^BGPEOMT("
- DO ^DIK
- +17 SET BGPX=0
- FOR
- SET BGPX=$ORDER(^BGPEOMIT(BGPX))
- IF BGPX'=+BGPX
- QUIT
- SET DA=BGPX
- SET DIK="^BGPEOMIT("
- DO ^DIK
- +18 FOR BGPX=1:1:2000
- KILL ^BGPTAXT(BGPX)
- +19 SET BGPX=0
- FOR
- SET BGPX=$ORDER(^BGPTAXTT(BGPX))
- IF BGPX'=+BGPX
- QUIT
- SET DA=BGPX
- SET DIK="^BGPTAXTT("
- DO ^DIK
- +20 FOR BGPX=1:1:2000
- KILL ^BGPTAXTT(BGPX)
- +21 SET X=0
- FOR
- SET X=$ORDER(^BGPSITE(X))
- IF X'=+X
- QUIT
- SET $PIECE(^BGPSITE(X,0),U,3)=""
- +22 SET X=0
- FOR
- SET X=$ORDER(^ATXAX(X))
- IF X'=+X
- QUIT
- Begin DoDot:1
- +23 IF $DATA(^ATXAX(X,21,0))
- IF $PIECE(^ATXAX(X,21,0),U,2)'["9002226.02101A"
- SET $PIECE(^ATXAX(X,21,0),U,2)="9002226.02101A"
- +24 IF $DATA(^ATXAX(X,41,0))
- IF $PIECE(^ATXAX(X,41,0),U,2)'["9002226.04101P"
- SET $PIECE(^ATXAX(X,41,0),U,2)="9002226.04101P"
- End DoDot:1
- +25 KILL ATXFLG
- +26 QUIT
