- IB20P402 ;ALB/CXW - SPECIALTY CODE IN FILE #399;09-SEP-08
- ;;2.0;INTEGRATED BILLING;**402**;21-MAR-94;Build 17
- ;;Per VHA Directive 2004-038, this routine should not be modified.
- POST ;
- START N U S U="^"
- D BMES^XPDUTL("Add the specialty code to file (#399), Post-Install Starting")
- ADD ;
- ;add the specialty to Field ID .08/subfile 399.0222
- ;the bill status is 1 - entered/not reviewed
- N DA,DA2,BILL,NUM,PRV,REC,SPEC,IBDT
- S DA=0,NUM=0
- F S DA=$O(^DGCR(399,DA)) Q:'DA I $P($G(^DGCR(399,DA,0)),U,13)=1 D
- . S DA2=0,BILL=$P($G(^DGCR(399,DA,0)),U)
- . F S DA2=$O(^DGCR(399,DA,"PRV",DA2)) Q:'DA2 D
- .. L +^DGCR(399,DA):1 I '$T D MES^XPDUTL("*7 ANOTHER USER IS EDITING BILL# "_BILL) Q
- .. S REC=$G(^DGCR(399,DA,"PRV",DA2,0))
- .. S PRV=$P(REC,U,2),IBDT=$P($G(^DGCR(399,DA,"U")),U)
- .. S SPEC=$$SPEC^IBCEU(PRV,IBDT)
- .. I $P(REC,U,8)="",SPEC'="" D
- ... S $P(^DGCR(399,DA,"PRV",DA2,0),U,8)=SPEC
- ... I PRV'["IBA(355.93" S PRV=$P($G(^VA(200,+PRV,0)),U)
- ... I PRV["IBA(355.93" S PRV=$P($G(^IBA(355.93,+PRV,0)),U)
- ... D MES^XPDUTL("Specialty Code "_SPEC_" for provider "_PRV_" added to bill# "_BILL)
- ... S NUM=NUM+1
- .. L -^DGCR(399,DA)
- D BMES^XPDUTL("Total "_NUM_$S(NUM=1:"bill has",1:" bills have")_" been updated")
- ;
- FINISH ;
- D BMES^XPDUTL("Add the specialty code to file (#399), Post-Install Complete")
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20P402 1345 printed Mar 13, 2025@21:07:24 Page 2
- IB20P402 ;ALB/CXW - SPECIALTY CODE IN FILE #399;09-SEP-08
- +1 ;;2.0;INTEGRATED BILLING;**402**;21-MAR-94;Build 17
- +2 ;;Per VHA Directive 2004-038, this routine should not be modified.
- POST ;
- START NEW U
- SET U="^"
- +1 DO BMES^XPDUTL("Add the specialty code to file (#399), Post-Install Starting")
- ADD ;
- +1 ;add the specialty to Field ID .08/subfile 399.0222
- +2 ;the bill status is 1 - entered/not reviewed
- +3 NEW DA,DA2,BILL,NUM,PRV,REC,SPEC,IBDT
- +4 SET DA=0
- SET NUM=0
- +5 FOR
- SET DA=$ORDER(^DGCR(399,DA))
- if 'DA
- QUIT
- IF $PIECE($GET(^DGCR(399,DA,0)),U,13)=1
- Begin DoDot:1
- +6 SET DA2=0
- SET BILL=$PIECE($GET(^DGCR(399,DA,0)),U)
- +7 FOR
- SET DA2=$ORDER(^DGCR(399,DA,"PRV",DA2))
- if 'DA2
- QUIT
- Begin DoDot:2
- +8 LOCK +^DGCR(399,DA):1
- IF '$TEST
- DO MES^XPDUTL("*7 ANOTHER USER IS EDITING BILL# "_BILL)
- QUIT
- +9 SET REC=$GET(^DGCR(399,DA,"PRV",DA2,0))
- +10 SET PRV=$PIECE(REC,U,2)
- SET IBDT=$PIECE($GET(^DGCR(399,DA,"U")),U)
- +11 SET SPEC=$$SPEC^IBCEU(PRV,IBDT)
- +12 IF $PIECE(REC,U,8)=""
- IF SPEC'=""
- Begin DoDot:3
- +13 SET $PIECE(^DGCR(399,DA,"PRV",DA2,0),U,8)=SPEC
- +14 IF PRV'["IBA(355.93"
- SET PRV=$PIECE($GET(^VA(200,+PRV,0)),U)
- +15 IF PRV["IBA(355.93"
- SET PRV=$PIECE($GET(^IBA(355.93,+PRV,0)),U)
- +16 DO MES^XPDUTL("Specialty Code "_SPEC_" for provider "_PRV_" added to bill# "_BILL)
- +17 SET NUM=NUM+1
- End DoDot:3
- +18 LOCK -^DGCR(399,DA)
- End DoDot:2
- End DoDot:1
- +19 DO BMES^XPDUTL("Total "_NUM_$SELECT(NUM=1:"bill has",1:" bills have")_" been updated")
- +20 ;
- FINISH ;
- +1 DO BMES^XPDUTL("Add the specialty code to file (#399), Post-Install Complete")
- +2 QUIT
- +3 ;
