IBJDE ;ALB/RB - DM DATA EXTRACTION (MAIN ROUTINE) ; 15-APR-99
;;2.0;INTEGRATED BILLING;**100,118,123,235,248,254,244,694**;21-MAR-94;Build 11
;
BJ ; - Entry point from IBAMTC.
I $D(^IBE(351.7,"DISABLE")) G ENQ ; DM extraction process disabled.
I '$$PROD^XUPROD() G ENQ ; IB*2.0*694 quit if not production account
;
I $E(DT,6,7)=$E($$LDATE(DT)+1,6,7) S IBDT=$E($P($$M1(DT,0),"^",1),1,5)_"00"
I '$G(IBDT) S IBDT=$$M1(DT,1)
I $E(IBDT,6,7)'="00" S IBDT=$E(IBDT,1,5)_"00"
I $D(^IBE(351.71,"AC",3,IBDT)) G ENQ ; Extract done for this date.
;
D NOW^%DTC S IBRD=%,IBS=$P(%H,",",2)
I $D(^IBE(351.71,IBDT,0)) D G ST ; Entry for this date already made.
.S DIE="^IBE(351.71,",DR=".02////1;.03////"_IBRD,DA=IBDT D ^DIE
.K DA,DIE,DR
;
; - Create entry in IB DM EXTRACT DATA ELEMENTS file (#351.71).
S DIC="^IBE(351.71,",DIC(0)="L",DIC("DR")=".02////1;.03////"_IBRD
S (DINUM,X)=IBDT K DD,DO D FILE^DICN K DIC,DINUM,DD,DO S IBDT=+Y
;
ST ; - Start extraction process.
I '$$CHK(IBDT) G COMP ; If data from all reports extracted, E-mail file.
;
N IBUNBILL
I $E(DT,6,7)=$E($$LDATE(DT)+1,6,7) S IBA0=$O(^IBE(351.7,"B","UNBILLED AMOUNTS REPORT",0)) G:'IBA0 ENQ S IBN0=^IBE(351.7,IBA0,0),IBUNBILL=1 D EXTRACT G ENQ
S IBA0=0 F S IBA0=$O(^IBE(351.7,IBA0)) Q:'IBA0 S IBN0=^(IBA0,0) I $P(IBN0,"^",1)'="UNBILLED AMOUNTS REPORT" S IBUNBILL=0 D EXTRACT
G ENQ
;
I $D(^IBE(351.71,"AD",3,IBDT,IBA0)) Q ; Extract of report done.
;
I '$D(^IBE(351.71,IBDT,1,IBA0,0)) D ; Create REPORT sub-file entry.
.S DIC="^IBE(351.71,"_IBDT_",1,",DIC(0)="L",DIC("DR")=".02////1"
.S DIC("P")="351.711P",DA(1)=IBDT,(DA,DINUM,X)=IBA0 K DD,DO
.D FILE^DICN K DA,DIC,DINUM,DD,DO
;
; - Set input variables.
S IBA1=0 N ZTIO,ZTDESC,ZTSK,ZTDTH,ZTRTN,ZTSAVE
F S IBA1=$O(^IBE(351.7,IBA0,1,IBA1)) Q:'IBA1 S IBN1=$G(^(IBA1,0)) D
.I $D(^IBE(351.7,IBA0,1,IBA1,1)) X ^(1)
.E S IBV=$P(IBN1,U),@(IBV)=$P(IBN1,U,2),ZTSAVE(IBV)=""
;
; - Set other ZT* variables for queueing.
S ZTSAVE("IBUNBILL")=""
S ZTDESC=$P(IBN0,U),ZTSAVE("IBXTRACT")=1,ZTIO=""
I $G(IBX) S ZTSAVE("IBXDATE")=IBDT ; Date from DME manual start option.
S ZTRTN=$G(^IBE(351.7,IBA0,2)) Q:ZTRTN="" I ZTRTN'["^" S ZTRTN=U_ZTRTN
S IBS=IBS+300,%=IBS D S^%DTC S ZTDTH=$P(IBRD,".")_% ; Run in 5 mins.
D ^%ZTLOAD
Q
;
;
E(RI,J) ; - Change report extract status/load DM summary report data.
; Input: RI=Report IEN from IB DM EXTRACT REPORTS file (#351.7).
; J=1-Change status, 0=Load DM data
S IBDT=$S($G(IBXDATE):$E(IBXDATE,1,5)_"00",'$G(IBUNBILL):$$M1(DT,1),1:$E($P($$M1(DT,0),"^",1),1,5)_"00") I 'J G E1
;
I '$D(^IBE(351.71,"AC",2,IBDT)) D ; Change extract status to STARTED.
.D NOW^%DTC S DIE="^IBE(351.71,",DR=".02////2;.03////"_%,DA=IBDT D ^DIE
.K DA,DIE,DR
;
; - Change report extract status to EXTRACT STARTED.
I '$D(^IBE(351.71,"AD",2,IBDT,RI)) D
.D NOW^%DTC S DIE="^IBE(351.71,"_IBDT_",1,",DR=".02////2;.03////"_%
.S DA(1)=IBDT,DA=RI D ^DIE K DA,DIE,DR
;
G ENQ
;
E1 ; - Load DM summary report data into file #351.71.
I $G(IBUNBILL) G E2
S IBA0=0 F S IBA0=$O(^IBE(351.701,"C",RI,IBA0)) Q:'IBA0 D
.S IBN0=$P($G(^IBE(351.701,IBA0,0)),U,2) Q:IBN0="" S IBN0=@(IBN0)
.;
.; - Create DATA ELEMENT sub-file entry in REPORT sub-file of #351.71
.S DIC="^IBE(351.71,"_IBDT_",1,"_RI_",1,",DIC(0)="L"
.S DIC("DR")=".02////"_IBN0,DIC("P")="351.7111P",DA(2)=IBDT,DA(1)=RI
.S (DA,DINUM,X)=IBA0 K DD,DO D FILE^DICN K DA,DIC,DINUM,DD,DO
;
; - Change status in REPORT sub-file of #351.71 to EXTRACT COMPLETED.
E2 D NOW^%DTC S DIE="^IBE(351.71,"_IBDT_",1,",DR=".02////3;.04////"_%
S DA(1)=IBDT,DA=RI D ^DIE K DA,DIE,DR,IBXDATE,IBXTRACT
;
; - Check if all data from all reports have been extracted, then change
; status in file #351.71 entry to EXTRACT COMPLETED.
I $$CHK(IBDT) G ENQ ; All reports not completed yet.
;
COMP D NOW^%DTC
S DIE="^IBE(351.71,",DR=".02////3;.04////"_%,DA=IBDT D ^DIE K DA,DIE,DR
I '$P(^IBE(351.71,IBDT,0),U,5) D XM^IBJDE1(IBDT) ; Transmit extract.
;
ENQ I '$G(IBX) K IBDT
K IBA0,IBA1,IBCT,IBN0,IBN1,IBRD,IBS,IBV,IBV1,X,Y,%
Q
;
M1(X,Y) ; - Return first/last day of month (if Y=0), previous month (if Y=1),
; first/last day of month in MMDDYYYY format (if Y=2), or date in
; external format (if Y=3).
N X1,X2 S:'$G(X)!(X'?7N.1".".6N) X=DT S:'$G(Y) Y=0
S X2="31^"_$S($E(X,1,3)#4=0:29,1:28)_"^31^30^31^30^31^31^30^31^30^31"
I 'Y S X=$E(X,1,5),X=X_"01"_U_X_$P(X2,U,+$E(X,4,5)) G M1Q
I Y=1 S X=($E(X,1,5)_"00")-$S(+$E(X,4,5)=1:8900,1:100) G M1Q
I Y=2 D G M1Q
.S X1=1700+$E(X,1,3),X=$E(X,4,5),X=X_"01"_X1_U_X_$P(X2,U,+X)_X1
S Y=X X ^DD("DD") S X=Y
M1Q Q X
;
M2(X,Y,Z,R) ; - Return specific date range.
; Input: X=Date in Fileman format
; Y=Number of months back from X
; Z=Number of months ahead from date created via Y
; R=0-Date range in Fileman format, 1-In MMDDYYYY format
N X1,X2
S:'$G(X) X=DT S:'$G(Y) Y=1 S:'$G(Z) Z=1 S:'$G(R) R=0 I X'?7N S X=DT
S X=$E(X,1,5)
S X1="31^"_$S($E(X,1,3)#4=0:29,1:28)_"^31^30^31^30^31^31^30^31^30^31"
F X2=1:1:Y S X=X-$S(+$E(X,4,5)=1:89,1:1) I X2=Y S X3=X_"01"
F X2=1:1:Z S X=X+$S(+$E(X,4,5)=12:89,1:1)
S X=X3_U_X_$P(X1,U,+$E(X,4,5)) I 'R G M2Q
S X1=1700+$E(X,1,3),X2=1700+$E(X,9,11),X=$E(X,4,7)_X1_U_$E(X,12,15)_X2
M2Q Q X
;
M3(X) ;Beginning date 365 days prior
N X1,X2
S X1=X,X2=-365 D C^%DTC
Q X
CHK(X) ; - Check if all extract reports have completed.
; Input: X=Date IEN of entry in file #351.71
; Output: Y=0-Completed, 1-Not completed
N X1,X2,X3 S (X1,X2,X3,Y)=0
F S X1=$O(^IBE(351.7,X1)) Q:'X1 I '$P(^(X1,0),U,2) S X2=X2+1
S X1=0 F S X1=$O(^IBE(351.71,"AD",3,X,X1)) Q:'X1 S X3=X3+1
I X2'=X3 S Y=1
Q Y
LDATE(X) ; DETERMINE CUT-OFF DATE FOR THE MONTH
S X=$E(X,1,5)_$P("31^28^31^30^31^30^31^31^30^31^30^31","^",+$E(X,4,5))
I +$E(X,6,7)=28,$E(X,2,3)#4=0 S $E(X,6,7)=29
S X=$$WORKPLUS^XUWORKDY(X,-3)
Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBJDE 6039 printed Sep 23, 2025@19:58:58 Page 2
IBJDE ;ALB/RB - DM DATA EXTRACTION (MAIN ROUTINE) ; 15-APR-99
+1 ;;2.0;INTEGRATED BILLING;**100,118,123,235,248,254,244,694**;21-MAR-94;Build 11
+2 ;
BJ ; - Entry point from IBAMTC.
+1 ; DM extraction process disabled.
IF $DATA(^IBE(351.7,"DISABLE"))
GOTO ENQ
+2 ; IB*2.0*694 quit if not production account
IF '$$PROD^XUPROD()
GOTO ENQ
+3 ;
+4 IF $EXTRACT(DT,6,7)=$EXTRACT($$LDATE(DT)+1,6,7)
SET IBDT=$EXTRACT($PIECE($$M1(DT,0),"^",1),1,5)_"00"
+5 IF '$GET(IBDT)
SET IBDT=$$M1(DT,1)
+6 IF $EXTRACT(IBDT,6,7)'="00"
SET IBDT=$EXTRACT(IBDT,1,5)_"00"
+7 ; Extract done for this date.
IF $DATA(^IBE(351.71,"AC",3,IBDT))
GOTO ENQ
+8 ;
+9 DO NOW^%DTC
SET IBRD=%
SET IBS=$PIECE(%H,",",2)
+10 ; Entry for this date already made.
IF $DATA(^IBE(351.71,IBDT,0))
Begin DoDot:1
+11 SET DIE="^IBE(351.71,"
SET DR=".02////1;.03////"_IBRD
SET DA=IBDT
DO ^DIE
+12 KILL DA,DIE,DR
End DoDot:1
GOTO ST
+13 ;
+14 ; - Create entry in IB DM EXTRACT DATA ELEMENTS file (#351.71).
+15 SET DIC="^IBE(351.71,"
SET DIC(0)="L"
SET DIC("DR")=".02////1;.03////"_IBRD
+16 SET (DINUM,X)=IBDT
KILL DD,DO
DO FILE^DICN
KILL DIC,DINUM,DD,DO
SET IBDT=+Y
+17 ;
ST ; - Start extraction process.
+1 ; If data from all reports extracted, E-mail file.
IF '$$CHK(IBDT)
GOTO COMP
+2 ;
+3 NEW IBUNBILL
+4 IF $EXTRACT(DT,6,7)=$EXTRACT($$LDATE(DT)+1,6,7)
SET IBA0=$ORDER(^IBE(351.7,"B","UNBILLED AMOUNTS REPORT",0))
if 'IBA0
GOTO ENQ
SET IBN0=^IBE(351.7,IBA0,0)
SET IBUNBILL=1
DO EXTRACT
GOTO ENQ
+5 SET IBA0=0
FOR
SET IBA0=$ORDER(^IBE(351.7,IBA0))
if 'IBA0
QUIT
SET IBN0=^(IBA0,0)
IF $PIECE(IBN0,"^",1)'="UNBILLED AMOUNTS REPORT"
SET IBUNBILL=0
DO EXTRACT
+6 GOTO ENQ
+7 ;
IF $PIECE(IBN0,U,2)
QUIT
+1 ; Extract of report done.
IF $DATA(^IBE(351.71,"AD",3,IBDT,IBA0))
QUIT
+2 ;
+3 ; Create REPORT sub-file entry.
IF '$DATA(^IBE(351.71,IBDT,1,IBA0,0))
Begin DoDot:1
+4 SET DIC="^IBE(351.71,"_IBDT_",1,"
SET DIC(0)="L"
SET DIC("DR")=".02////1"
+5 SET DIC("P")="351.711P"
SET DA(1)=IBDT
SET (DA,DINUM,X)=IBA0
KILL DD,DO
+6 DO FILE^DICN
KILL DA,DIC,DINUM,DD,DO
End DoDot:1
+7 ;
+8 ; - Set input variables.
+9 SET IBA1=0
NEW ZTIO,ZTDESC,ZTSK,ZTDTH,ZTRTN,ZTSAVE
+10 FOR
SET IBA1=$ORDER(^IBE(351.7,IBA0,1,IBA1))
if 'IBA1
QUIT
SET IBN1=$GET(^(IBA1,0))
Begin DoDot:1
+11 IF $DATA(^IBE(351.7,IBA0,1,IBA1,1))
XECUTE ^(1)
+12 IF '$TEST
SET IBV=$PIECE(IBN1,U)
SET @(IBV)=$PIECE(IBN1,U,2)
SET ZTSAVE(IBV)=""
End DoDot:1
+13 ;
+14 ; - Set other ZT* variables for queueing.
+15 SET ZTSAVE("IBUNBILL")=""
+16 SET ZTDESC=$PIECE(IBN0,U)
SET ZTSAVE("IBXTRACT")=1
SET ZTIO=""
+17 ; Date from DME manual start option.
IF $GET(IBX)
SET ZTSAVE("IBXDATE")=IBDT
+18 SET ZTRTN=$GET(^IBE(351.7,IBA0,2))
if ZTRTN=""
QUIT
IF ZTRTN'["^"
SET ZTRTN=U_ZTRTN
+19 ; Run in 5 mins.
SET IBS=IBS+300
SET %=IBS
DO S^%DTC
SET ZTDTH=$PIECE(IBRD,".")_%
+20 DO ^%ZTLOAD
+21 QUIT
+22 ;
+23 ;
E(RI,J) ; - Change report extract status/load DM summary report data.
+1 ; Input: RI=Report IEN from IB DM EXTRACT REPORTS file (#351.7).
+2 ; J=1-Change status, 0=Load DM data
+3 SET IBDT=$SELECT($GET(IBXDATE):$EXTRACT(IBXDATE,1,5)_"00",'$GET(IBUNBILL):$$M1(DT,1),1:$EXTRACT($PIECE($$M1(DT,0),"^",1),1,5)_"00")
IF 'J
GOTO E1
+4 ;
+5 ; Change extract status to STARTED.
IF '$DATA(^IBE(351.71,"AC",2,IBDT))
Begin DoDot:1
+6 DO NOW^%DTC
SET DIE="^IBE(351.71,"
SET DR=".02////2;.03////"_%
SET DA=IBDT
DO ^DIE
+7 KILL DA,DIE,DR
End DoDot:1
+8 ;
+9 ; - Change report extract status to EXTRACT STARTED.
+10 IF '$DATA(^IBE(351.71,"AD",2,IBDT,RI))
Begin DoDot:1
+11 DO NOW^%DTC
SET DIE="^IBE(351.71,"_IBDT_",1,"
SET DR=".02////2;.03////"_%
+12 SET DA(1)=IBDT
SET DA=RI
DO ^DIE
KILL DA,DIE,DR
End DoDot:1
+13 ;
+14 GOTO ENQ
+15 ;
E1 ; - Load DM summary report data into file #351.71.
+1 IF $GET(IBUNBILL)
GOTO E2
+2 SET IBA0=0
FOR
SET IBA0=$ORDER(^IBE(351.701,"C",RI,IBA0))
if 'IBA0
QUIT
Begin DoDot:1
+3 SET IBN0=$PIECE($GET(^IBE(351.701,IBA0,0)),U,2)
if IBN0=""
QUIT
SET IBN0=@(IBN0)
+4 ;
+5 ; - Create DATA ELEMENT sub-file entry in REPORT sub-file of #351.71
+6 SET DIC="^IBE(351.71,"_IBDT_",1,"_RI_",1,"
SET DIC(0)="L"
+7 SET DIC("DR")=".02////"_IBN0
SET DIC("P")="351.7111P"
SET DA(2)=IBDT
SET DA(1)=RI
+8 SET (DA,DINUM,X)=IBA0
KILL DD,DO
DO FILE^DICN
KILL DA,DIC,DINUM,DD,DO
End DoDot:1
+9 ;
+10 ; - Change status in REPORT sub-file of #351.71 to EXTRACT COMPLETED.
E2 DO NOW^%DTC
SET DIE="^IBE(351.71,"_IBDT_",1,"
SET DR=".02////3;.04////"_%
+1 SET DA(1)=IBDT
SET DA=RI
DO ^DIE
KILL DA,DIE,DR,IBXDATE,IBXTRACT
+2 ;
+3 ; - Check if all data from all reports have been extracted, then change
+4 ; status in file #351.71 entry to EXTRACT COMPLETED.
+5 ; All reports not completed yet.
IF $$CHK(IBDT)
GOTO ENQ
+6 ;
COMP DO NOW^%DTC
+1 SET DIE="^IBE(351.71,"
SET DR=".02////3;.04////"_%
SET DA=IBDT
DO ^DIE
KILL DA,DIE,DR
+2 ; Transmit extract.
IF '$PIECE(^IBE(351.71,IBDT,0),U,5)
DO XM^IBJDE1(IBDT)
+3 ;
ENQ IF '$GET(IBX)
KILL IBDT
+1 KILL IBA0,IBA1,IBCT,IBN0,IBN1,IBRD,IBS,IBV,IBV1,X,Y,%
+2 QUIT
+3 ;
M1(X,Y) ; - Return first/last day of month (if Y=0), previous month (if Y=1),
+1 ; first/last day of month in MMDDYYYY format (if Y=2), or date in
+2 ; external format (if Y=3).
+3 NEW X1,X2
if '$GET(X)!(X'?7N.1".".6N)
SET X=DT
if '$GET(Y)
SET Y=0
+4 SET X2="31^"_$SELECT($EXTRACT(X,1,3)#4=0:29,1:28)_"^31^30^31^30^31^31^30^31^30^31"
+5 IF 'Y
SET X=$EXTRACT(X,1,5)
SET X=X_"01"_U_X_$PIECE(X2,U,+$EXTRACT(X,4,5))
GOTO M1Q
+6 IF Y=1
SET X=($EXTRACT(X,1,5)_"00")-$SELECT(+$EXTRACT(X,4,5)=1:8900,1:100)
GOTO M1Q
+7 IF Y=2
Begin DoDot:1
+8 SET X1=1700+$EXTRACT(X,1,3)
SET X=$EXTRACT(X,4,5)
SET X=X_"01"_X1_U_X_$PIECE(X2,U,+X)_X1
End DoDot:1
GOTO M1Q
+9 SET Y=X
XECUTE ^DD("DD")
SET X=Y
M1Q QUIT X
+1 ;
M2(X,Y,Z,R) ; - Return specific date range.
+1 ; Input: X=Date in Fileman format
+2 ; Y=Number of months back from X
+3 ; Z=Number of months ahead from date created via Y
+4 ; R=0-Date range in Fileman format, 1-In MMDDYYYY format
+5 NEW X1,X2
+6 if '$GET(X)
SET X=DT
if '$GET(Y)
SET Y=1
if '$GET(Z)
SET Z=1
if '$GET(R)
SET R=0
IF X'?7N
SET X=DT
+7 SET X=$EXTRACT(X,1,5)
+8 SET X1="31^"_$SELECT($EXTRACT(X,1,3)#4=0:29,1:28)_"^31^30^31^30^31^31^30^31^30^31"
+9 FOR X2=1:1:Y
SET X=X-$SELECT(+$EXTRACT(X,4,5)=1:89,1:1)
IF X2=Y
SET X3=X_"01"
+10 FOR X2=1:1:Z
SET X=X+$SELECT(+$EXTRACT(X,4,5)=12:89,1:1)
+11 SET X=X3_U_X_$PIECE(X1,U,+$EXTRACT(X,4,5))
IF 'R
GOTO M2Q
+12 SET X1=1700+$EXTRACT(X,1,3)
SET X2=1700+$EXTRACT(X,9,11)
SET X=$EXTRACT(X,4,7)_X1_U_$EXTRACT(X,12,15)_X2
M2Q QUIT X
+1 ;
M3(X) ;Beginning date 365 days prior
+1 NEW X1,X2
+2 SET X1=X
SET X2=-365
DO C^%DTC
+3 QUIT X
CHK(X) ; - Check if all extract reports have completed.
+1 ; Input: X=Date IEN of entry in file #351.71
+2 ; Output: Y=0-Completed, 1-Not completed
+3 NEW X1,X2,X3
SET (X1,X2,X3,Y)=0
+4 FOR
SET X1=$ORDER(^IBE(351.7,X1))
if 'X1
QUIT
IF '$PIECE(^(X1,0),U,2)
SET X2=X2+1
+5 SET X1=0
FOR
SET X1=$ORDER(^IBE(351.71,"AD",3,X,X1))
if 'X1
QUIT
SET X3=X3+1
+6 IF X2'=X3
SET Y=1
+7 QUIT Y
LDATE(X) ; DETERMINE CUT-OFF DATE FOR THE MONTH
+1 SET X=$EXTRACT(X,1,5)_$PIECE("31^28^31^30^31^30^31^31^30^31^30^31","^",+$EXTRACT(X,4,5))
+2 IF +$EXTRACT(X,6,7)=28
IF $EXTRACT(X,2,3)#4=0
SET $EXTRACT(X,6,7)=29
+3 SET X=$$WORKPLUS^XUWORKDY(X,-3)
+4 QUIT X
