- IBYPPC1 ;ALB/ARH - IB*2*52 POST INIT: CM POST INIT (CONT) ; 16-MAY-1996
- ;;Version 2.0 ; INTEGRATED BILLING ;**52,86**; 21-MAR-94
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- ;
- ADDBS ; Add Billable Service (399.1, .2=1)
- N IBA,IBCNT,IBI,IBLN,IBFN,IBX,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y S IBCNT=0
- ;
- F IBI=1:1 S IBLN=$P($T(BSF+IBI^IBYPPC5),";;",2) Q:+IBLN!(IBLN="") I $E(IBLN)?1A D
- . ;
- . I +$$MCCRUTL($P(IBLN,U,1),13) Q
- . ;
- . K DD,DO S DLAYGO=399.1,DIC="^DGCR(399.1,",DIC(0)="L",X=$P(IBLN,U,1) D FILE^DICN K DIC I Y<1 K X,Y Q
- . S IBFN=+Y,IBCNT=IBCNT+1
- . ;
- . S DR=".03////"_$P(IBLN,U,2)_";.2////"_1
- . S DIE="^DGCR(399.1,",DA=+IBFN D ^DIE K DIE,DA,DR,X,Y
- ;
- BSQ S IBA(1)=" >> "_IBCNT_" Billable Services added (399.1)..."
- D MES^XPDUTL(.IBA)
- Q
- ;
- ADDBE ; Add Billable Events (399.1, .21=1)
- N IBA,IBCNT,IBI,IBLN,IBFN,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y S IBCNT=0
- ;
- F IBI=1:1 S IBLN=$P($T(BEF+IBI^IBYPPC5),";;",2) Q:+IBLN!(IBLN="") I $E(IBLN)?1A D
- . ;
- . I +$$MCCRUTL($P(IBLN,U,1),14) Q
- . ;
- . K DD,DO S DLAYGO=399.1,DIC="^DGCR(399.1,",DIC(0)="L",X=$P(IBLN,U,1) D FILE^DICN K DIC I Y<1 K X,Y Q
- . S IBFN=+Y,IBCNT=IBCNT+1
- . ;
- . S DR=".03////"_$P(IBLN,U,2)_";.21////"_1
- . S DIE="^DGCR(399.1,",DA=+IBFN D ^DIE K DIE,DA,DR,X,Y
- ;
- BEQ S IBA(1)=" >> "_IBCNT_" Billable Events added (399.1)..."
- D MES^XPDUTL(.IBA)
- Q
- ;
- ADDBR ; Add Billing Rates (363.3)
- N IBA,IBCNT,IBI,IBLN,IBFN,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y S IBCNT=0
- ;
- F IBI=1:1 S IBLN=$P($T(BRF+IBI^IBYPPC5),";;",2) Q:+IBLN!(IBLN="") I $E(IBLN)?1A D
- . ;
- . I $O(^IBE(363.3,"B",$P(IBLN,U,1),0)) Q
- . ;
- . K DD,DO S DLAYGO=363.3,DIC="^IBE(363.3,",DIC(0)="L",X=$P(IBLN,U,1) D FILE^DICN K DIC I Y<1 K X,Y Q
- . S IBFN=+Y,IBCNT=IBCNT+1
- . ;
- . S DR=".02////"_$P(IBLN,U,2)_";.03////"_$P(IBLN,U,3)_";.04////"_$P(IBLN,U,4)_";.05////"_$P(IBLN,U,5)
- . S DIE="^IBE(363.3,",DA=+IBFN D ^DIE K DIE,DA,DR,X,Y
- ;
- BRQ S IBA(1)=" >> "_IBCNT_" Billing Rates added (363.3)..."
- D MES^XPDUTL(.IBA)
- Q
- ;
- ADDCS ; Add Charge Sets (363.1)
- N IBA,IBCNT,IBI,IBLN,IBFN,IBBR,IBBE,IBRVCD,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y S IBCNT=0
- ;
- F IBI=1:1 S IBLN=$P($T(CSF+IBI^IBYPPC5),";;",2) Q:+IBLN!(IBLN="") I $E(IBLN)?1A D
- . ;
- . I $O(^IBE(363.1,"B",$P(IBLN,U,1),0)) Q
- . S IBBR=$P(IBLN,U,2),IBBR=$O(^IBE(363.3,"B",IBBR,0)) I 'IBBR Q
- . S IBBE=$$MCCRUTL($P(IBLN,U,3),14) Q:'IBBE
- . S IBRVCD=$$RVCD($P(IBLN,U,5))
- . ;
- . K DD,DO S DLAYGO=363.1,DIC="^IBE(363.1,",DIC(0)="L",X=$P(IBLN,U,1) D FILE^DICN K DIC I Y<1 K X,Y Q
- . S IBFN=+Y,IBCNT=IBCNT+1
- . ;
- . S DR=".02////"_IBBR_";.03////"_IBBE
- . I +$P(IBLN,U,4) S DR=DR_";.04////"_$P(IBLN,U,4)
- . I +IBRVCD S DR=DR_";.05////"_IBRVCD
- . S DIE="^IBE(363.1,",DA=+IBFN D ^DIE K DIE,DA,DR,X,Y
- ;
- CSQ S IBA(1)=" >> "_IBCNT_" Charge Sets added (363.1)..."
- D MES^XPDUTL(.IBA)
- Q
- ;
- ADDCI ; Add Charge Items (363.2) needs Charge Sets
- N IBA,IBCNT,IBI,IBLN,IBFN,IBCS,IBCI,IBRVCD,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y,IBX S IBCNT=0
- ;
- F IBI=1:1 S IBLN=$P($T(CIF+IBI^IBYPPC61),";;",2) Q:+IBLN!(IBLN="") I $E(IBLN)?1A D SETCI
- F IBI=1:1 S IBLN=$P($T(CIF+IBI^IBYPPC6),";;",2) Q:+IBLN!(IBLN="") I $E(IBLN)?1A D SETCI
- F IBI=1:1 S IBLN=$P($T(CIF+IBI^IBYPPC7),";;",2) Q:+IBLN!(IBLN="") I $E(IBLN)?1A D SETCI
- ;
- CIQ S IBA(1)=" >> "_IBCNT_" Charge Items added (363.2)..."
- D MES^XPDUTL(.IBA)
- Q
- ;
- SETCI ; set Charge Item (duplicates based on item, CS, eff dt, rev cd)
- ;
- S IBCS=$P(IBLN,U,2),IBCS=+$O(^IBE(363.1,"B",IBCS,0)) I 'IBCS Q
- S IBCI=+$$MCCRUTL($P(IBLN,U,1),5) I 'IBCI Q
- S IBRVCD=$$RVCD($P(IBLN,U,4))
- S IBX=0 F S IBX=$O(^IBA(363.2,"AIVDTS"_IBCS,IBCI,-$P(IBLN,U,3),IBX)) Q:'IBX I $P(^IBA(363.2,IBX,0),U,6)=IBRVCD S IBCI=0
- Q:'IBCI
- ;
- K DD,DO S DLAYGO=363.2,DIC="^IBA(363.2,",DIC(0)="L",X=IBCI_";DGCR(399.1," D FILE^DICN K DIC I Y<1 K X,Y Q
- S IBFN=+Y,IBCNT=IBCNT+1
- ;
- S DR=".02////"_IBCS_";.03////"_$P(IBLN,U,3)_";.05////"_$P(IBLN,U,5)
- I +IBRVCD S DR=DR_";.06////"_IBRVCD
- S DIE="^IBA(363.2,",DA=+IBFN D ^DIE K DIE,DA,DR,X,Y
- Q
- ;
- ADDRS ; add Rate Schedules (363) (needs billable service and charge sets)
- N IBA,IBCNT,IBI,IBLN,IBFN,IBRT,IBBS,IBJ,IBLNCS,IBCS,IBCSFN,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y S IBCNT=0
- ;
- F IBI=1:1 S IBLN=$P($T(RSF+IBI^IBYPPC5),";;",2) Q:+IBLN!(IBLN="") I $E(IBLN)?1A D
- . ;
- . I $O(^IBE(363,"B",$P(IBLN,U,1),0)) Q
- . S IBBS=$P(IBLN,U,4) I IBBS'="" S IBBS=$$MCCRUTL(IBBS,13) Q:'IBBS
- . S IBRT=$P(IBLN,U,2),IBRT=$O(^DGCR(399.3,"B",IBRT,0)) D Q:'IBRT
- .. I 'IBRT D MSG(" **** Rate Type "_$P(IBLN,U,2)_" not defined, RS "_$P(IBLN,U,1)_" not created")
- .. I +$P($G(^DGCR(399.3,+IBRT,0)),U,3) S IBRT=0 D MSG(" **** Rate Type "_$P(IBLN,U,2)_" not Active, RS "_$P(IBLN,U,1)_" not created")
- . ;
- . K DD,DO S DLAYGO=363,DIC="^IBE(363,",DIC(0)="L",X=$P(IBLN,U,1) D FILE^DICN K DIC,DINUM,DLAYGO I Y<1 K X,Y Q
- . S IBFN=+Y,IBCNT=IBCNT+1
- . ;
- . S DR=".02////"_IBRT_";.03////"_$P(IBLN,U,3) I +IBBS S DR=DR_";.04////"_IBBS
- . ;
- . S DIE="^IBE(363,",DA=+Y D ^DIE K DIE,DA,DR,X,Y
- . ;
- . ; charge sets (multiple)
- . S IBLNCS=$P(IBLN,":",2,999) F IBJ=1:1 S IBCS=$P(IBLNCS,":",IBJ) Q:IBCS="" D
- .. S IBCSFN=$O(^IBE(363.1,"B",IBCS,0)) Q:'IBCSFN
- .. ;
- .. S DLAYGO=363,DA(1)=+IBFN,DIC="^IBE(363,"_DA(1)_",11,",DIC(0)="L",X=IBCS,DIC("DR")=".02////"_1,DIC("P")="363.0011P" D ^DIC K DIC,DIE
- ;
- ;
- RSQ S IBA(1)=" >> "_IBCNT_" Rate Schedules added (363)..."
- D MES^XPDUTL(.IBA)
- Q
- ;
- MCCRUTL(X,P) ; returns IFN of item in 399.1 if Name is found and piece P is true
- N IBX,IBY S IBY=""
- I $G(X)'="" S IBX=0 F S IBX=$O(^DGCR(399.1,"B",X,IBX)) Q:'IBX I $P($G(^DGCR(399.1,IBX,0)),U,+$G(P)) S IBY=IBX
- Q IBY
- ;
- RVCD(RVCD) ; returns IFN if revenue code is valid and active
- N IBX,IBY S IBY=""
- I +$G(RVCD) S IBX=$G(^DGCR(399.2,+RVCD,0)) I +$P(IBX,U,3) S IBY=RVCD
- Q IBY
- ;
- MSG(X) ;
- N IBX S IBX=$O(IBA(999999),-1) S:'IBX IBX=1 S IBX=IBX+1
- S IBA(IBX)=$G(X)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBYPPC1 5948 printed Mar 13, 2025@21:41:36 Page 2
- IBYPPC1 ;ALB/ARH - IB*2*52 POST INIT: CM POST INIT (CONT) ; 16-MAY-1996
- +1 ;;Version 2.0 ; INTEGRATED BILLING ;**52,86**; 21-MAR-94
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 ;
- +4 ;
- ADDBS ; Add Billable Service (399.1, .2=1)
- +1 NEW IBA,IBCNT,IBI,IBLN,IBFN,IBX,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y
- SET IBCNT=0
- +2 ;
- +3 FOR IBI=1:1
- SET IBLN=$PIECE($TEXT(BSF+IBI^IBYPPC5),";;",2)
- if +IBLN!(IBLN="")
- QUIT
- IF $EXTRACT(IBLN)?1A
- Begin DoDot:1
- +4 ;
- +5 IF +$$MCCRUTL($PIECE(IBLN,U,1),13)
- QUIT
- +6 ;
- +7 KILL DD,DO
- SET DLAYGO=399.1
- SET DIC="^DGCR(399.1,"
- SET DIC(0)="L"
- SET X=$PIECE(IBLN,U,1)
- DO FILE^DICN
- KILL DIC
- IF Y<1
- KILL X,Y
- QUIT
- +8 SET IBFN=+Y
- SET IBCNT=IBCNT+1
- +9 ;
- +10 SET DR=".03////"_$PIECE(IBLN,U,2)_";.2////"_1
- +11 SET DIE="^DGCR(399.1,"
- SET DA=+IBFN
- DO ^DIE
- KILL DIE,DA,DR,X,Y
- End DoDot:1
- +12 ;
- BSQ SET IBA(1)=" >> "_IBCNT_" Billable Services added (399.1)..."
- +1 DO MES^XPDUTL(.IBA)
- +2 QUIT
- +3 ;
- ADDBE ; Add Billable Events (399.1, .21=1)
- +1 NEW IBA,IBCNT,IBI,IBLN,IBFN,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y
- SET IBCNT=0
- +2 ;
- +3 FOR IBI=1:1
- SET IBLN=$PIECE($TEXT(BEF+IBI^IBYPPC5),";;",2)
- if +IBLN!(IBLN="")
- QUIT
- IF $EXTRACT(IBLN)?1A
- Begin DoDot:1
- +4 ;
- +5 IF +$$MCCRUTL($PIECE(IBLN,U,1),14)
- QUIT
- +6 ;
- +7 KILL DD,DO
- SET DLAYGO=399.1
- SET DIC="^DGCR(399.1,"
- SET DIC(0)="L"
- SET X=$PIECE(IBLN,U,1)
- DO FILE^DICN
- KILL DIC
- IF Y<1
- KILL X,Y
- QUIT
- +8 SET IBFN=+Y
- SET IBCNT=IBCNT+1
- +9 ;
- +10 SET DR=".03////"_$PIECE(IBLN,U,2)_";.21////"_1
- +11 SET DIE="^DGCR(399.1,"
- SET DA=+IBFN
- DO ^DIE
- KILL DIE,DA,DR,X,Y
- End DoDot:1
- +12 ;
- BEQ SET IBA(1)=" >> "_IBCNT_" Billable Events added (399.1)..."
- +1 DO MES^XPDUTL(.IBA)
- +2 QUIT
- +3 ;
- ADDBR ; Add Billing Rates (363.3)
- +1 NEW IBA,IBCNT,IBI,IBLN,IBFN,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y
- SET IBCNT=0
- +2 ;
- +3 FOR IBI=1:1
- SET IBLN=$PIECE($TEXT(BRF+IBI^IBYPPC5),";;",2)
- if +IBLN!(IBLN="")
- QUIT
- IF $EXTRACT(IBLN)?1A
- Begin DoDot:1
- +4 ;
- +5 IF $ORDER(^IBE(363.3,"B",$PIECE(IBLN,U,1),0))
- QUIT
- +6 ;
- +7 KILL DD,DO
- SET DLAYGO=363.3
- SET DIC="^IBE(363.3,"
- SET DIC(0)="L"
- SET X=$PIECE(IBLN,U,1)
- DO FILE^DICN
- KILL DIC
- IF Y<1
- KILL X,Y
- QUIT
- +8 SET IBFN=+Y
- SET IBCNT=IBCNT+1
- +9 ;
- +10 SET DR=".02////"_$PIECE(IBLN,U,2)_";.03////"_$PIECE(IBLN,U,3)_";.04////"_$PIECE(IBLN,U,4)_";.05////"_$PIECE(IBLN,U,5)
- +11 SET DIE="^IBE(363.3,"
- SET DA=+IBFN
- DO ^DIE
- KILL DIE,DA,DR,X,Y
- End DoDot:1
- +12 ;
- BRQ SET IBA(1)=" >> "_IBCNT_" Billing Rates added (363.3)..."
- +1 DO MES^XPDUTL(.IBA)
- +2 QUIT
- +3 ;
- ADDCS ; Add Charge Sets (363.1)
- +1 NEW IBA,IBCNT,IBI,IBLN,IBFN,IBBR,IBBE,IBRVCD,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y
- SET IBCNT=0
- +2 ;
- +3 FOR IBI=1:1
- SET IBLN=$PIECE($TEXT(CSF+IBI^IBYPPC5),";;",2)
- if +IBLN!(IBLN="")
- QUIT
- IF $EXTRACT(IBLN)?1A
- Begin DoDot:1
- +4 ;
- +5 IF $ORDER(^IBE(363.1,"B",$PIECE(IBLN,U,1),0))
- QUIT
- +6 SET IBBR=$PIECE(IBLN,U,2)
- SET IBBR=$ORDER(^IBE(363.3,"B",IBBR,0))
- IF 'IBBR
- QUIT
- +7 SET IBBE=$$MCCRUTL($PIECE(IBLN,U,3),14)
- if 'IBBE
- QUIT
- +8 SET IBRVCD=$$RVCD($PIECE(IBLN,U,5))
- +9 ;
- +10 KILL DD,DO
- SET DLAYGO=363.1
- SET DIC="^IBE(363.1,"
- SET DIC(0)="L"
- SET X=$PIECE(IBLN,U,1)
- DO FILE^DICN
- KILL DIC
- IF Y<1
- KILL X,Y
- QUIT
- +11 SET IBFN=+Y
- SET IBCNT=IBCNT+1
- +12 ;
- +13 SET DR=".02////"_IBBR_";.03////"_IBBE
- +14 IF +$PIECE(IBLN,U,4)
- SET DR=DR_";.04////"_$PIECE(IBLN,U,4)
- +15 IF +IBRVCD
- SET DR=DR_";.05////"_IBRVCD
- +16 SET DIE="^IBE(363.1,"
- SET DA=+IBFN
- DO ^DIE
- KILL DIE,DA,DR,X,Y
- End DoDot:1
- +17 ;
- CSQ SET IBA(1)=" >> "_IBCNT_" Charge Sets added (363.1)..."
- +1 DO MES^XPDUTL(.IBA)
- +2 QUIT
- +3 ;
- ADDCI ; Add Charge Items (363.2) needs Charge Sets
- +1 NEW IBA,IBCNT,IBI,IBLN,IBFN,IBCS,IBCI,IBRVCD,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y,IBX
- SET IBCNT=0
- +2 ;
- +3 FOR IBI=1:1
- SET IBLN=$PIECE($TEXT(CIF+IBI^IBYPPC61),";;",2)
- if +IBLN!(IBLN="")
- QUIT
- IF $EXTRACT(IBLN)?1A
- DO SETCI
- +4 FOR IBI=1:1
- SET IBLN=$PIECE($TEXT(CIF+IBI^IBYPPC6),";;",2)
- if +IBLN!(IBLN="")
- QUIT
- IF $EXTRACT(IBLN)?1A
- DO SETCI
- +5 FOR IBI=1:1
- SET IBLN=$PIECE($TEXT(CIF+IBI^IBYPPC7),";;",2)
- if +IBLN!(IBLN="")
- QUIT
- IF $EXTRACT(IBLN)?1A
- DO SETCI
- +6 ;
- CIQ SET IBA(1)=" >> "_IBCNT_" Charge Items added (363.2)..."
- +1 DO MES^XPDUTL(.IBA)
- +2 QUIT
- +3 ;
- SETCI ; set Charge Item (duplicates based on item, CS, eff dt, rev cd)
- +1 ;
- +2 SET IBCS=$PIECE(IBLN,U,2)
- SET IBCS=+$ORDER(^IBE(363.1,"B",IBCS,0))
- IF 'IBCS
- QUIT
- +3 SET IBCI=+$$MCCRUTL($PIECE(IBLN,U,1),5)
- IF 'IBCI
- QUIT
- +4 SET IBRVCD=$$RVCD($PIECE(IBLN,U,4))
- +5 SET IBX=0
- FOR
- SET IBX=$ORDER(^IBA(363.2,"AIVDTS"_IBCS,IBCI,-$PIECE(IBLN,U,3),IBX))
- if 'IBX
- QUIT
- IF $PIECE(^IBA(363.2,IBX,0),U,6)=IBRVCD
- SET IBCI=0
- +6 if 'IBCI
- QUIT
- +7 ;
- +8 KILL DD,DO
- SET DLAYGO=363.2
- SET DIC="^IBA(363.2,"
- SET DIC(0)="L"
- SET X=IBCI_";DGCR(399.1,"
- DO FILE^DICN
- KILL DIC
- IF Y<1
- KILL X,Y
- QUIT
- +9 SET IBFN=+Y
- SET IBCNT=IBCNT+1
- +10 ;
- +11 SET DR=".02////"_IBCS_";.03////"_$PIECE(IBLN,U,3)_";.05////"_$PIECE(IBLN,U,5)
- +12 IF +IBRVCD
- SET DR=DR_";.06////"_IBRVCD
- +13 SET DIE="^IBA(363.2,"
- SET DA=+IBFN
- DO ^DIE
- KILL DIE,DA,DR,X,Y
- +14 QUIT
- +15 ;
- ADDRS ; add Rate Schedules (363) (needs billable service and charge sets)
- +1 NEW IBA,IBCNT,IBI,IBLN,IBFN,IBRT,IBBS,IBJ,IBLNCS,IBCS,IBCSFN,DD,DO,DLAYGO,DIC,DIE,DA,DR,X,Y
- SET IBCNT=0
- +2 ;
- +3 FOR IBI=1:1
- SET IBLN=$PIECE($TEXT(RSF+IBI^IBYPPC5),";;",2)
- if +IBLN!(IBLN="")
- QUIT
- IF $EXTRACT(IBLN)?1A
- Begin DoDot:1
- +4 ;
- +5 IF $ORDER(^IBE(363,"B",$PIECE(IBLN,U,1),0))
- QUIT
- +6 SET IBBS=$PIECE(IBLN,U,4)
- IF IBBS'=""
- SET IBBS=$$MCCRUTL(IBBS,13)
- if 'IBBS
- QUIT
- +7 SET IBRT=$PIECE(IBLN,U,2)
- SET IBRT=$ORDER(^DGCR(399.3,"B",IBRT,0))
- Begin DoDot:2
- +8 IF 'IBRT
- DO MSG(" **** Rate Type "_$PIECE(IBLN,U,2)_" not defined, RS "_$PIECE(IBLN,U,1)_" not created")
- +9 IF +$PIECE($GET(^DGCR(399.3,+IBRT,0)),U,3)
- SET IBRT=0
- DO MSG(" **** Rate Type "_$PIECE(IBLN,U,2)_" not Active, RS "_$PIECE(IBLN,U,1)_" not created")
- End DoDot:2
- if 'IBRT
- QUIT
- +10 ;
- +11 KILL DD,DO
- SET DLAYGO=363
- SET DIC="^IBE(363,"
- SET DIC(0)="L"
- SET X=$PIECE(IBLN,U,1)
- DO FILE^DICN
- KILL DIC,DINUM,DLAYGO
- IF Y<1
- KILL X,Y
- QUIT
- +12 SET IBFN=+Y
- SET IBCNT=IBCNT+1
- +13 ;
- +14 SET DR=".02////"_IBRT_";.03////"_$PIECE(IBLN,U,3)
- IF +IBBS
- SET DR=DR_";.04////"_IBBS
- +15 ;
- +16 SET DIE="^IBE(363,"
- SET DA=+Y
- DO ^DIE
- KILL DIE,DA,DR,X,Y
- +17 ;
- +18 ; charge sets (multiple)
- +19 SET IBLNCS=$PIECE(IBLN,":",2,999)
- FOR IBJ=1:1
- SET IBCS=$PIECE(IBLNCS,":",IBJ)
- if IBCS=""
- QUIT
- Begin DoDot:2
- +20 SET IBCSFN=$ORDER(^IBE(363.1,"B",IBCS,0))
- if 'IBCSFN
- QUIT
- +21 ;
- +22 SET DLAYGO=363
- SET DA(1)=+IBFN
- SET DIC="^IBE(363,"_DA(1)_",11,"
- SET DIC(0)="L"
- SET X=IBCS
- SET DIC("DR")=".02////"_1
- SET DIC("P")="363.0011P"
- DO ^DIC
- KILL DIC,DIE
- End DoDot:2
- End DoDot:1
- +23 ;
- +24 ;
- RSQ SET IBA(1)=" >> "_IBCNT_" Rate Schedules added (363)..."
- +1 DO MES^XPDUTL(.IBA)
- +2 QUIT
- +3 ;
- MCCRUTL(X,P) ; returns IFN of item in 399.1 if Name is found and piece P is true
- +1 NEW IBX,IBY
- SET IBY=""
- +2 IF $GET(X)'=""
- SET IBX=0
- FOR
- SET IBX=$ORDER(^DGCR(399.1,"B",X,IBX))
- if 'IBX
- QUIT
- IF $PIECE($GET(^DGCR(399.1,IBX,0)),U,+$GET(P))
- SET IBY=IBX
- +3 QUIT IBY
- +4 ;
- RVCD(RVCD) ; returns IFN if revenue code is valid and active
- +1 NEW IBX,IBY
- SET IBY=""
- +2 IF +$GET(RVCD)
- SET IBX=$GET(^DGCR(399.2,+RVCD,0))
- IF +$PIECE(IBX,U,3)
- SET IBY=RVCD
- +3 QUIT IBY
- +4 ;
- MSG(X) ;
- +1 NEW IBX
- SET IBX=$ORDER(IBA(999999),-1)
- if 'IBX
- SET IBX=1
- SET IBX=IBX+1
- +2 SET IBA(IBX)=$GET(X)
- +3 QUIT
