IBECECU2.m

IBECECU2 ;ALB/CLT - SECONDARY INPUT OF DSP DATA ; 08 Jul 2022  9:25 AM

 ;;2.0;INTEGRATED BILLING;**704**;21-MAR-94;Build 49

 ;Per VA Directive 6402, this routine should not be modified.

 ;

 ;

 Q

EN(IBCLDT1,DFN) ;ENTRY POINT FOR ADDING ENTRIES TO 351.3

 ;Create a new entry in file 351.3

 N DIC,IBFDA,IEN,IBIENS,X,Y,IEN3513,IBERR,IB351DA,DIE,DA,DR,IBREFNUM

 S DIC="^IBE(351.3,",DIC(0)=""

 S IB351DA=$O(^IBE(351,"AIVDT",DFN,-IBCLDT1,";"),-1) Q:'IB351DA

 S IBREFNUM=$P(^IBE(351,IB351DA,0),U)

 S DA=$O(^IBE(351.3,"B",IBREFNUM,0))

 I +DA=0 S X=IBREFNUM D FILE^DICN S DA=$P(Y,U,1)

 S DIE=DIC,DR=".02////^S X=DFN" D ^DIE

 D NEWSUB

 Q

NEWSUB ;Create and Load new sub-file entry

 ;S DA(1)=DA

 ;S DIC=DIC_DA(1)_",1,"

 ;S DIC(0)="L"

 ;S X=IBCLDA

 ;D ^DIC S DA=+Y

 I IBISTAT=1 S IBISTAT="CU"

 S IBIENS="+1,"_DA_","

 S IBFDA(351.31,IBIENS,.01)=IBCLDA

 S:$G(IBICLDT)'="" IBFDA(351.31,IBIENS,.02)=IBICLDT

 S:$G(IBISTAT)'="" IBFDA(351.31,IBIENS,.03)=IBISTAT

 S:$G(IBI901)'="" IBFDA(351.31,IBIENS,.04)=IBI901

 S:$G(IBI902)="" IBFDA(351.31,IBIENS,.05)=IBI902

 S:$G(IBI903)'="" IBFDA(351.31,IBIENS,.06)=IBI903

 S:$G(IBI904)'="" IBFDA(351.31,IBIENS,.07)=IBI904

 S:$G(IBICLDAY)'="" IBFDA(351.31,IBIENS,.08)=IBICLDAY

 S:$G(IBICKDT)'="" IBFDA(351.31,IBIENS,.09)=IBICKDT

 S:$G(IBISITE)'="" IBFDA(351.31,IBIENS,10)=IBISITE

 D UPDATE^DIE(,"IBFDA","IBERR")

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---IBECECU2   1370     printed  Apr 09, 2024@21:10:53                                                                                                                                                                                                    Page 2

IBECECU2  ;ALB/CLT - SECONDARY INPUT OF DSP DATA ; 08 Jul 2022  9:25 AM

 +1       ;;2.0;INTEGRATED BILLING;**704**;21-MAR-94;Build 49

 +2       ;Per VA Directive 6402, this routine should not be modified.

 +3       ;

 +4       ;

 +5        QUIT 

EN(IBCLDT1,DFN) ;ENTRY POINT FOR ADDING ENTRIES TO 351.3

 +1       ;Create a new entry in file 351.3

 +2        NEW DIC,IBFDA,IEN,IBIENS,X,Y,IEN3513,IBERR,IB351DA,DIE,DA,DR,IBREFNUM

 +3        SET DIC="^IBE(351.3,"

           SET DIC(0)=""

 +4        SET IB351DA=$ORDER(^IBE(351,"AIVDT",DFN,-IBCLDT1,";"),-1)

           if 'IB351DA

               QUIT 

 +5        SET IBREFNUM=$PIECE(^IBE(351,IB351DA,0),U)

 +6        SET DA=$ORDER(^IBE(351.3,"B",IBREFNUM,0))

 +7        IF +DA=0

               SET X=IBREFNUM

               DO FILE^DICN

               SET DA=$PIECE(Y,U,1)

 +8        SET DIE=DIC

           SET DR=".02////^S X=DFN"

           DO ^DIE

 +9        DO NEWSUB

 +10       QUIT 

NEWSUB    ;Create and Load new sub-file entry

 +1       ;S DA(1)=DA

 +2       ;S DIC=DIC_DA(1)_",1,"

 +3       ;S DIC(0)="L"

 +4       ;S X=IBCLDA

 +5       ;D ^DIC S DA=+Y

 +6        IF IBISTAT=1

               SET IBISTAT="CU"

 +7        SET IBIENS="+1,"_DA_","

 +8        SET IBFDA(351.31,IBIENS,.01)=IBCLDA

 +9        if $GET(IBICLDT)'=""

               SET IBFDA(351.31,IBIENS,.02)=IBICLDT

 +10       if $GET(IBISTAT)'=""

               SET IBFDA(351.31,IBIENS,.03)=IBISTAT

 +11       if $GET(IBI901)'=""

               SET IBFDA(351.31,IBIENS,.04)=IBI901

 +12       if $GET(IBI902)=""

               SET IBFDA(351.31,IBIENS,.05)=IBI902

 +13       if $GET(IBI903)'=""

               SET IBFDA(351.31,IBIENS,.06)=IBI903

 +14       if $GET(IBI904)'=""

               SET IBFDA(351.31,IBIENS,.07)=IBI904

 +15       if $GET(IBICLDAY)'=""

               SET IBFDA(351.31,IBIENS,.08)=IBICLDAY

 +16       if $GET(IBICKDT)'=""

               SET IBFDA(351.31,IBIENS,.09)=IBICKDT

 +17       if $GET(IBISITE)'=""

               SET IBFDA(351.31,IBIENS,10)=IBISITE

 +18       DO UPDATE^DIE(,"IBFDA","IBERR")

 +19       QUIT