- BGP9POS2 ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 28 Jan 2005 1:34 PM ;
- ;;9.0;IHS CLINICAL REPORTING;;JUL 1, 2009
- ;
- ;
- PRE ;EP
- ;CHANGE PACKAGE FILE NAME
- S BGPX=0 F S BGPX=$O(^BGPPEIN(BGPX)) Q:BGPX'=+BGPX S DA=BGPX,DIK="^BGPPEIN(" D ^DIK
- S BGPX=0 F S BGPX=$O(^BGPELIN(BGPX)) Q:BGPX'=+BGPX S DA=BGPX,DIK="^BGPELIN(" D ^DIK
- S BGPX=0 F S BGPX=$O(^BGPELIIN(BGPX)) Q:BGPX'=+BGPX S DA=BGPX,DIK="^BGPELIIN(" D ^DIK
- S BGPX=0 F S BGPX=$O(^BGPCMSIN(BGPX)) Q:BGPX'=+BGPX S DA=BGPX,DIK="^BGPCMSIN(" D ^DIK
- S BGPX=0 F S BGPX=$O(^BGPNPLN(BGPX)) Q:BGPX'=+BGPX S DA=BGPX,DIK="^BGPNPLN(" D ^DIK
- S BGPX=0 F S BGPX=$O(^BGPHEIN(BGPX)) Q:BGPX'=+BGPX S DA=BGPX,DIK="^BGPHEIN(" D ^DIK
- S BGPX=0 F S BGPX=$O(^BGPHEIIN(BGPX)) Q:BGPX'=+BGPX S DA=BGPX,DIK="^BGPHEIIN(" D ^DIK
- S BGPX=0 F S BGPX=$O(^BGPINDNC(BGPX)) Q:BGPX'=+BGPX S DA=BGPX,DIK="^BGPINDNC(" D ^DIK
- S BGPX=0 F S BGPX=$O(^BGPINDN(BGPX)) Q:BGPX'=+BGPX S DA=BGPX,DIK="^BGPINDN(" D ^DIK
- S BGPX=0 F S BGPX=$O(^BGPTAXN(BGPX)) Q:BGPX'=+BGPX S DA=BGPX,DIK="^BGPTAXN(" D ^DIK
- S BGPX=0 F S BGPX=$O(^BGPCMSMN(BGPX)) Q:BGPX'=+BGPX S DA=BGPX,DIK="^BGPCMSMN(" 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(^BGPICAGN(BGPX)) Q:BGPX'=+BGPX S DA=BGPX,DIK="^BGPICAGN(" D ^DIK
- S BGPX=0 F S BGPX=$O(^BGPICACN(BGPX)) Q:BGPX'=+BGPX S DA=BGPX,DIK="^BGPICACN(" D ^DIK
- F BGPX=0 F S BGPX=$O(^BGPEOMN(BGPX)) Q:BGPX'=+BGPX S DA=BGPX,DIK="^BGPEOMN(" D ^DIK
- S BGPX=0 F S BGPX=$O(^BGPEOMIN(BGPX)) Q:BGPX'=+BGPX S DA=BGPX,DIK="^BGPEOMIN(" D ^DIK
- F BGPX=1:1:2000 K ^BGPTAXN(BGPX)
- S BGPX=0 F S BGPX=$O(^BGPTAXTN(BGPX)) Q:BGPX'=+BGPX S DA=BGPX,DIK="^BGPTAXTN(" D ^DIK
- F BGPX=1:1:2000 K ^BGPTAXTN(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"
- CH S DA=$O(^ATXAX("B","BGP TOTAL CHOLECTOMY CPTS",0)) I DA D
- .S DIE="^ATXAX(",DR=".01///BGP TOTAL COLECTOMY CPTS",ATXFLG=1 D ^DIE K DIE,DA,DR
- S DA=$O(^ATXAX("B","BGP TOTAL CHOLECTOMY PROCS",0)) I DA D
- .S DIE="^ATXAX(",DR=".01///BGP TOTAL COLECTOMY PROCS",ATXFLG=1 D ^DIE K DIE,DA,DR
- K ATXFLG
- Q
- BGP9POS2 ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 28 Jan 2005 1:34 PM ;
- +1 ;;9.0;IHS CLINICAL REPORTING;;JUL 1, 2009
- +2 ;
- +3 ;
- PRE ;EP
- +1 ;CHANGE PACKAGE FILE NAME
- +2 SET BGPX=0
- FOR
- SET BGPX=$ORDER(^BGPPEIN(BGPX))
- IF BGPX'=+BGPX
- QUIT
- SET DA=BGPX
- SET DIK="^BGPPEIN("
- DO ^DIK
- +3 SET BGPX=0
- FOR
- SET BGPX=$ORDER(^BGPELIN(BGPX))
- IF BGPX'=+BGPX
- QUIT
- SET DA=BGPX
- SET DIK="^BGPELIN("
- DO ^DIK
- +4 SET BGPX=0
- FOR
- SET BGPX=$ORDER(^BGPELIIN(BGPX))
- IF BGPX'=+BGPX
- QUIT
- SET DA=BGPX
- SET DIK="^BGPELIIN("
- DO ^DIK
- +5 SET BGPX=0
- FOR
- SET BGPX=$ORDER(^BGPCMSIN(BGPX))
- IF BGPX'=+BGPX
- QUIT
- SET DA=BGPX
- SET DIK="^BGPCMSIN("
- DO ^DIK
- +6 SET BGPX=0
- FOR
- SET BGPX=$ORDER(^BGPNPLN(BGPX))
- IF BGPX'=+BGPX
- QUIT
- SET DA=BGPX
- SET DIK="^BGPNPLN("
- DO ^DIK
- +7 SET BGPX=0
- FOR
- SET BGPX=$ORDER(^BGPHEIN(BGPX))
- IF BGPX'=+BGPX
- QUIT
- SET DA=BGPX
- SET DIK="^BGPHEIN("
- DO ^DIK
- +8 SET BGPX=0
- FOR
- SET BGPX=$ORDER(^BGPHEIIN(BGPX))
- IF BGPX'=+BGPX
- QUIT
- SET DA=BGPX
- SET DIK="^BGPHEIIN("
- DO ^DIK
- +9 SET BGPX=0
- FOR
- SET BGPX=$ORDER(^BGPINDNC(BGPX))
- IF BGPX'=+BGPX
- QUIT
- SET DA=BGPX
- SET DIK="^BGPINDNC("
- DO ^DIK
- +10 SET BGPX=0
- FOR
- SET BGPX=$ORDER(^BGPINDN(BGPX))
- IF BGPX'=+BGPX
- QUIT
- SET DA=BGPX
- SET DIK="^BGPINDN("
- DO ^DIK
- +11 SET BGPX=0
- FOR
- SET BGPX=$ORDER(^BGPTAXN(BGPX))
- IF BGPX'=+BGPX
- QUIT
- SET DA=BGPX
- SET DIK="^BGPTAXN("
- DO ^DIK
- +12 SET BGPX=0
- FOR
- SET BGPX=$ORDER(^BGPCMSMN(BGPX))
- IF BGPX'=+BGPX
- QUIT
- SET DA=BGPX
- SET DIK="^BGPCMSMN("
- 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(^BGPICAGN(BGPX))
- IF BGPX'=+BGPX
- QUIT
- SET DA=BGPX
- SET DIK="^BGPICAGN("
- DO ^DIK
- +15 SET BGPX=0
- FOR
- SET BGPX=$ORDER(^BGPICACN(BGPX))
- IF BGPX'=+BGPX
- QUIT
- SET DA=BGPX
- SET DIK="^BGPICACN("
- DO ^DIK
- +16 FOR BGPX=0
- FOR
- SET BGPX=$ORDER(^BGPEOMN(BGPX))
- IF BGPX'=+BGPX
- QUIT
- SET DA=BGPX
- SET DIK="^BGPEOMN("
- DO ^DIK
- +17 SET BGPX=0
- FOR
- SET BGPX=$ORDER(^BGPEOMIN(BGPX))
- IF BGPX'=+BGPX
- QUIT
- SET DA=BGPX
- SET DIK="^BGPEOMIN("
- DO ^DIK
- +18 FOR BGPX=1:1:2000
- KILL ^BGPTAXN(BGPX)
- +19 SET BGPX=0
- FOR
- SET BGPX=$ORDER(^BGPTAXTN(BGPX))
- IF BGPX'=+BGPX
- QUIT
- SET DA=BGPX
- SET DIK="^BGPTAXTN("
- DO ^DIK
- +20 FOR BGPX=1:1:2000
- KILL ^BGPTAXTN(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
- CH SET DA=$ORDER(^ATXAX("B","BGP TOTAL CHOLECTOMY CPTS",0))
- IF DA
- Begin DoDot:1
- +1 SET DIE="^ATXAX("
- SET DR=".01///BGP TOTAL COLECTOMY CPTS"
- SET ATXFLG=1
- DO ^DIE
- KILL DIE,DA,DR
- End DoDot:1
- +2 SET DA=$ORDER(^ATXAX("B","BGP TOTAL CHOLECTOMY PROCS",0))
- IF DA
- Begin DoDot:1
- +3 SET DIE="^ATXAX("
- SET DR=".01///BGP TOTAL COLECTOMY PROCS"
- SET ATXFLG=1
- DO ^DIE
- KILL DIE,DA,DR
- End DoDot:1
- +4 KILL ATXFLG
- +5 QUIT
