IB2P562A ;ALB/BG - SPECIAL INP BILLING MENU OPTION;3/21/16
;;2.0;INTEGRATED BILLING;**562**;21-MAR-94;Build 10
;;Per VA Directive 6402, this routine should not be modified
;
Q
;
;updating discharge dates missing in file IBE(351.2)
;
UPDATE ;file update
N IBCT,IBPTF,IBDPTF,IBDDT
S IBCT=0 F S IBCT=$O(^IBE(351.2,IBCT)) Q:'IBCT I $P($G(^IBE(351.2,IBCT,0)),"^",5)'=2 D
.S IBPTF=$P($G(^IBE(351.2,IBCT,0)),"^",2) Q:'IBPTF
.Q:$P($G(^DGPM(IBPTF,0)),"^",17)=""
.S IBDPTF=$P($G(^DGPM(IBPTF,0)),"^",17),IBDDT=$P($G(^DGPM(IBDPTF,0)),"^")
.N DA,DIE,DR
.S DR=".05////2;.06////"_IBDDT_";2.03////"_DUZ_";2.04///NOW"
.S DA=IBCT,DIE="^IBE(351.2," D ^DIE
W !,"File Update Complete"
W !,"Please review records using the List Special Inpatient Billing Cases Menu Option",!!
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB2P562A 801 printed Dec 13, 2024@02:05:42 Page 2
IB2P562A ;ALB/BG - SPECIAL INP BILLING MENU OPTION;3/21/16
+1 ;;2.0;INTEGRATED BILLING;**562**;21-MAR-94;Build 10
+2 ;;Per VA Directive 6402, this routine should not be modified
+3 ;
+4 QUIT
+5 ;
+6 ;updating discharge dates missing in file IBE(351.2)
+7 ;
UPDATE ;file update
+1 NEW IBCT,IBPTF,IBDPTF,IBDDT
+2 SET IBCT=0
FOR
SET IBCT=$ORDER(^IBE(351.2,IBCT))
if 'IBCT
QUIT
IF $PIECE($GET(^IBE(351.2,IBCT,0)),"^",5)'=2
Begin DoDot:1
+3 SET IBPTF=$PIECE($GET(^IBE(351.2,IBCT,0)),"^",2)
if 'IBPTF
QUIT
+4 if $PIECE($GET(^DGPM(IBPTF,0)),"^",17)=""
QUIT
+5 SET IBDPTF=$PIECE($GET(^DGPM(IBPTF,0)),"^",17)
SET IBDDT=$PIECE($GET(^DGPM(IBDPTF,0)),"^")
+6 NEW DA,DIE,DR
+7 SET DR=".05////2;.06////"_IBDDT_";2.03////"_DUZ_";2.04///NOW"
+8 SET DA=IBCT
SET DIE="^IBE(351.2,"
DO ^DIE
End DoDot:1
+9 WRITE !,"File Update Complete"
+10 WRITE !,"Please review records using the List Special Inpatient Billing Cases Menu Option",!!
+11 QUIT
+12 ;
