IBCRHBA.m

IBCRHBA ;ALB/ARH - RATES: UPLOAD HOST FILES (AWP) ; 11-FEB-1997

 ;;2.0;INTEGRATED BILLING;**52,106**;21-MAR-94

 ;;Per VHA Directive 10-93-142, this routine should not be modified.

 ;

 ;

AWP ; OPTION: upload an AVERAGE WHOLESALE PRICE file from a VMS file into ^XTMP

 ;

 N DIR,DIRUT,DUOUT,X,Y,IBI,IBFILE,IBPATH,IBXRF,IBXRF1,IBXRF2,IBFLINE,IBX,IBY

 N IBEFDT,IBNDC,IBNDCO,IBNDCN,IBCHGD,IBCHGC,IBCHG

 W !!,"Upload Average Wholesale Price list from a host file:   'AWP_mmddyy.TXT'"

 ;

 S IBPATH=$$PATH I IBPATH<0 Q

 I '$$FNDHOST(IBPATH) Q

 ;

 S DIR("?")="Enter a AWP Host File Name of format:  'AWP_mmddyy.TXT'"

 S DIR(0)="FO^3:60",DIR("A")="Enter a Host File Name" D ^DIR K DIR Q:$D(DIRUT)  S IBFILE=Y

 ;

 I ($E(IBFILE,1,4)'="AWP_")!($E(IBFILE,5,10)'?6N)!($E(IBFILE,11,14)'=".TXT") W !!,"**** File not an AWP file: must be 'AWP_mmddyy.TXT'.",! Q

 ;

 S IBEFDT=$$GETDT^IBCRU1(2961101) I IBEFDT'?7N Q

 W !!,"All NDC numbers will be added to the Charge Master with the form of: 5n-4n-2n.",!!

 ;

 S IBXRF="IBCR UPLOAD "_IBFILE I '$$CONT(IBXRF) Q

 I '$$CONT1 Q

 ;

 ;

 D OPEN^%ZISH("AWP UPLOAD",IBPATH,IBFILE,"R") I POP W !!,"**** Unable to open ",IBPATH,IBFILE,! Q

 ;

 U IO(0) W !!,"Loading ",IBFILE," into ^XTMP "

 ;

 S IBI=0 F  S IBI=IBI+1 U IO R IBFLINE:5 Q:$$ENDF  D PARSE,STORE I '(IBI#100) U IO(0) W "."

 ;

 D CLOSE^%ZISH("AWP UPLOAD")

 ;

 ;

 W !!,"Done. ",(IBI-1)," lines processed."

 W !,"The following files were created, they will be purged in 2 days:" D DISP1^IBCRHU1(IBXRF)

 Q

 ;

ENDF() N IBX S IBX=1 I $T,IBFLINE'="" S IBX=0

 I $$STATUS^%ZISH S IBX=1

 I IBFLINE?36"9" S IBX=1

 I 'IBX,IBFLINE'?36N D

 . U IO(0)

 . W !!,"**** Error while reading file: line not expected format (36 numeric characters):"

 . W !!,"Line Length=",$L(IBFLINE)," characters" W:IBFLINE="" ?40,"Line read is null"

 . W !,"LINE='",IBFLINE,"'",!!,"Upload Aborted!"

 . S IBX=1 H 7 U IO

 I IBI=1,IBFLINE="" U IO(0) W !!,"First line of file has no data, can not continue!" S IBX=1 H 7 U IO

 Q IBX

 ;

PARSE ; process a single line from a AWP file: parse out into individual fields and store the line in XTMP

 ;

 S IBNDCO=$E(IBFLINE,1,11) ; old NDC #

 S IBNDCN=$E(IBFLINE,12,22) ; new NDC #

 S IBCHGD=$E(IBFLINE,23,25) ; charge, dollars

 S IBCHGC=$E(IBFLINE,26,29) ; charge, cents

 Q

 ;

STORE ;

 S IBXRF1=IBXRF

 S IBXRF2="AWP"

 S IBNDC=IBNDCO I +IBNDCN S IBNDC=IBNDCN

 S IBNDC=$$NDCSET(IBNDC)

 S IBCHG=IBCHGD_"."_IBCHGC

 S IBCHG=+$FN(+IBCHG,"",2)

 ;

 D SET

 ;

 Q

 ;

SET ;

 N IBX S IBX=$G(^XTMP(IBXRF1,0)) I IBX="" D SETHDR

 S $P(^XTMP(IBXRF1,0),U,4)=+$P(IBX,U,4)+1

 S ^XTMP(IBXRF1,IBXRF2)=(+$G(^XTMP(IBXRF1,IBXRF2))+1)_U_3

 S ^XTMP(IBXRF1,IBXRF2,IBI)=IBNDC_U_IBEFDT_U_U_IBCHG

 Q

 ;

SETHDR ;

 N IBX S IBX="IB upload of Host file "_IBFILE_", on "_$$HTE^XLFDT($H,2)_" by "_$P($G(^VA(200,+$G(DUZ),0)),U,1)

 S ^XTMP(IBXRF1,0)=$$FMADD^XLFDT(DT,2)_U_DT_U_IBX

 Q

 ;

CONT(XREF) ; check for existing files stored in XREF with same host file name

 ; returns true if user wants to continue and these files are deleted

 ;

 N ARR,IBX,IBY,IBZ,DIR,DIRUT,DUOUT,X,Y S ARR=0,IBZ=1 W !

 ;

 D DISP1^IBCRHU1(XREF,.ARR)

 ;

 I +ARR S IBZ=0 D  W !

 . W !!,"The above files already exist in XTMP." S DIR("?")="Enter either 'Y' or 'N'.  This files use the same name as the new upload would use and therefore must be deleted before the upload can proceed."

 . S DIR("A")="Delete the above files and continue with upload",DIR(0)="Y" D ^DIR K DIR

 . ;

 . I Y=1 S IBZ=1,IBX="" F  S IBX=$O(ARR(IBX)) Q:IBX=""  K ^XTMP(IBX) W "."

 ;

 Q IBZ

 ;

CONT1() ; get final OK to start upload

 N IBZ,DIR,DIRUT,DUOUT,X,Y S IBZ=0 W !

 S DIR("A")="Proceed with upload now",DIR(0)="Y" D ^DIR K DIR I Y=1 S IBZ=1

 Q IBZ

 ;

PATH() ; return directory or -1

 N IBPATH,DIR,DIRUT,DUOUT,X,Y S IBPATH=""

 S DIR("?",1)="Enter the full path specification where the host files may be found"

 S DIR("?")="or press return for the default directory "_$$PWD^%ZISH

 S DIR(0)="FO^3:60",DIR("A")="Enter the file path",DIR("B")=$$PWD^%ZISH D ^DIR K DIR

 S IBPATH=$S($D(DUOUT)!$D(DTOUT):-1,1:Y)

 Q IBPATH

 ;

FNDHOST(IBPATH) ; find and display any host files available for upload: 1 if some, 0 none found

 N IBX,IBY,IBZ S IBZ=0

 ;

 W !,"AWP Host files available for upload in ",IBPATH,":",!!

 S IBX("AWP*")="",IBZ=$$LIST^%ZISH(IBPATH,"IBX","IBY")

 I 'IBZ W "**** No AWP files found ",IBPATH,"AWP_mmddyy.TXT, can not continue.",!

 I +IBZ S IBX="" F  S IBX=$O(IBY(IBX)) Q:IBX=""  W ?30,$P(IBX,";",1),!

 Q IBZ

 ;

NDCSET(X) ; parse NDC number:  raw form from VMS file is 11 numbers, parsed to 5n-4n-2n

 N Y S Y="" S Y=$E(X,1,5)_"-"_$E(X,6,9)_"-"_$E(X,10,11)

 Q Y

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---IBCRHBA   4682     printed  Mar 13, 2025@21:24:07                                                                                                                                                                                                     Page 2

IBCRHBA   ;ALB/ARH - RATES: UPLOAD HOST FILES (AWP) ; 11-FEB-1997

 +1       ;;2.0;INTEGRATED BILLING;**52,106**;21-MAR-94

 +2       ;;Per VHA Directive 10-93-142, this routine should not be modified.

 +3       ;

 +4       ;

AWP       ; OPTION: upload an AVERAGE WHOLESALE PRICE file from a VMS file into ^XTMP

 +1       ;

 +2        NEW DIR,DIRUT,DUOUT,X,Y,IBI,IBFILE,IBPATH,IBXRF,IBXRF1,IBXRF2,IBFLINE,IBX,IBY

 +3        NEW IBEFDT,IBNDC,IBNDCO,IBNDCN,IBCHGD,IBCHGC,IBCHG

 +4        WRITE !!,"Upload Average Wholesale Price list from a host file:   'AWP_mmddyy.TXT'"

 +5       ;

 +6        SET IBPATH=$$PATH

           IF IBPATH<0

               QUIT 

 +7        IF '$$FNDHOST(IBPATH)

               QUIT 

 +8       ;

 +9        SET DIR("?")="Enter a AWP Host File Name of format:  'AWP_mmddyy.TXT'"

 +10       SET DIR(0)="FO^3:60"

           SET DIR("A")="Enter a Host File Name"

           DO ^DIR

           KILL DIR

           if $DATA(DIRUT)

               QUIT 

           SET IBFILE=Y

 +11      ;

 +12       IF ($EXTRACT(IBFILE,1,4)'="AWP_")!($EXTRACT(IBFILE,5,10)'?6N)!($EXTRACT(IBFILE,11,14)'=".TXT")

               WRITE !!,"**** File not an AWP file: must be 'AWP_mmddyy.TXT'.",!

               QUIT 

 +13      ;

 +14       SET IBEFDT=$$GETDT^IBCRU1(2961101)

           IF IBEFDT'?7N

               QUIT 

 +15       WRITE !!,"All NDC numbers will be added to the Charge Master with the form of: 5n-4n-2n.",!!

 +16      ;

 +17       SET IBXRF="IBCR UPLOAD "_IBFILE

           IF '$$CONT(IBXRF)

               QUIT 

 +18       IF '$$CONT1

               QUIT 

 +19      ;

 +20      ;

 +21       DO OPEN^%ZISH("AWP UPLOAD",IBPATH,IBFILE,"R")

           IF POP

               WRITE !!,"**** Unable to open ",IBPATH,IBFILE,!

               QUIT 

 +22      ;

 +23       USE IO(0)

           WRITE !!,"Loading ",IBFILE," into ^XTMP "

 +24      ;

 +25       SET IBI=0

           FOR 

               SET IBI=IBI+1

               USE IO

               READ IBFLINE:5

               if $$ENDF

                   QUIT 

               DO PARSE

               DO STORE

               IF '(IBI#100)

                   USE IO(0)

                   WRITE "."

 +26      ;

 +27       DO CLOSE^%ZISH("AWP UPLOAD")

 +28      ;

 +29      ;

 +30       WRITE !!,"Done. ",(IBI-1)," lines processed."

 +31       WRITE !,"The following files were created, they will be purged in 2 days:"

           DO DISP1^IBCRHU1(IBXRF)

 +32       QUIT 

 +33      ;

ENDF()     NEW IBX

           SET IBX=1

           IF $TEST

               IF IBFLINE'=""

                   SET IBX=0

 +1        IF $$STATUS^%ZISH

               SET IBX=1

 +2        IF IBFLINE?36"9"

               SET IBX=1

 +3        IF 'IBX

               IF IBFLINE'?36N

                   Begin DoDot:1

 +4                    USE IO(0)

 +5                    WRITE !!,"**** Error while reading file: line not expected format (36 numeric characters):"

 +6                    WRITE !!,"Line Length=",$LENGTH(IBFLINE)," characters"

                       if IBFLINE=""

                           WRITE ?40,"Line read is null"

 +7                    WRITE !,"LINE='",IBFLINE,"'",!!,"Upload Aborted!"

 +8                    SET IBX=1

                       HANG 7

                       USE IO

                   End DoDot:1

 +9        IF IBI=1

               IF IBFLINE=""

                   USE IO(0)

                   WRITE !!,"First line of file has no data, can not continue!"

                   SET IBX=1

                   HANG 7

                   USE IO

 +10       QUIT IBX

 +11      ;

PARSE     ; process a single line from a AWP file: parse out into individual fields and store the line in XTMP

 +1       ;

 +2       ; old NDC #

           SET IBNDCO=$EXTRACT(IBFLINE,1,11)

 +3       ; new NDC #

           SET IBNDCN=$EXTRACT(IBFLINE,12,22)

 +4       ; charge, dollars

           SET IBCHGD=$EXTRACT(IBFLINE,23,25)

 +5       ; charge, cents

           SET IBCHGC=$EXTRACT(IBFLINE,26,29)

 +6        QUIT 

 +7       ;

STORE     ;

 +1        SET IBXRF1=IBXRF

 +2        SET IBXRF2="AWP"

 +3        SET IBNDC=IBNDCO

           IF +IBNDCN

               SET IBNDC=IBNDCN

 +4        SET IBNDC=$$NDCSET(IBNDC)

 +5        SET IBCHG=IBCHGD_"."_IBCHGC

 +6        SET IBCHG=+$FNUMBER(+IBCHG,"",2)

 +7       ;

 +8        DO SET

 +9       ;

 +10       QUIT 

 +11      ;

SET       ;

 +1        NEW IBX

           SET IBX=$GET(^XTMP(IBXRF1,0))

           IF IBX=""

               DO SETHDR

 +2        SET $PIECE(^XTMP(IBXRF1,0),U,4)=+$PIECE(IBX,U,4)+1

 +3        SET ^XTMP(IBXRF1,IBXRF2)=(+$GET(^XTMP(IBXRF1,IBXRF2))+1)_U_3

 +4        SET ^XTMP(IBXRF1,IBXRF2,IBI)=IBNDC_U_IBEFDT_U_U_IBCHG

 +5        QUIT 

 +6       ;

SETHDR    ;

 +1        NEW IBX

           SET IBX="IB upload of Host file "_IBFILE_", on "_$$HTE^XLFDT($HOROLOG,2)_" by "_$PIECE($GET(^VA(200,+$GET(DUZ),0)),U,1)

 +2        SET ^XTMP(IBXRF1,0)=$$FMADD^XLFDT(DT,2)_U_DT_U_IBX

 +3        QUIT 

 +4       ;

CONT(XREF) ; check for existing files stored in XREF with same host file name

 +1       ; returns true if user wants to continue and these files are deleted

 +2       ;

 +3        NEW ARR,IBX,IBY,IBZ,DIR,DIRUT,DUOUT,X,Y

           SET ARR=0

           SET IBZ=1

           WRITE !

 +4       ;

 +5        DO DISP1^IBCRHU1(XREF,.ARR)

 +6       ;

 +7        IF +ARR

               SET IBZ=0

               Begin DoDot:1

 +8                WRITE !!,"The above files already exist in XTMP."

                   SET DIR("?")="Enter either 'Y' or 'N'.  This files use the same name as the new upload would use and therefore must be deleted before the upload can proceed."

 +9                SET DIR("A")="Delete the above files and continue with upload"

                   SET DIR(0)="Y"

                   DO ^DIR

                   KILL DIR

 +10      ;

 +11               IF Y=1

                       SET IBZ=1

                       SET IBX=""

                       FOR 

                           SET IBX=$ORDER(ARR(IBX))

                           if IBX=""

                               QUIT 

                           KILL ^XTMP(IBX)

                           WRITE "."

               End DoDot:1

               WRITE !

 +12      ;

 +13       QUIT IBZ

 +14      ;

CONT1()   ; get final OK to start upload

 +1        NEW IBZ,DIR,DIRUT,DUOUT,X,Y

           SET IBZ=0

           WRITE !

 +2        SET DIR("A")="Proceed with upload now"

           SET DIR(0)="Y"

           DO ^DIR

           KILL DIR

           IF Y=1

               SET IBZ=1

 +3        QUIT IBZ

 +4       ;

PATH()    ; return directory or -1

 +1        NEW IBPATH,DIR,DIRUT,DUOUT,X,Y

           SET IBPATH=""

 +2        SET DIR("?",1)="Enter the full path specification where the host files may be found"

 +3        SET DIR("?")="or press return for the default directory "_$$PWD^%ZISH

 +4        SET DIR(0)="FO^3:60"

           SET DIR("A")="Enter the file path"

           SET DIR("B")=$$PWD^%ZISH

           DO ^DIR

           KILL DIR

 +5        SET IBPATH=$SELECT($DATA(DUOUT)!$DATA(DTOUT):-1,1:Y)

 +6        QUIT IBPATH

 +7       ;

FNDHOST(IBPATH) ; find and display any host files available for upload: 1 if some, 0 none found

 +1        NEW IBX,IBY,IBZ

           SET IBZ=0

 +2       ;

 +3        WRITE !,"AWP Host files available for upload in ",IBPATH,":",!!

 +4        SET IBX("AWP*")=""

           SET IBZ=$$LIST^%ZISH(IBPATH,"IBX","IBY")

 +5        IF 'IBZ

               WRITE "**** No AWP files found ",IBPATH,"AWP_mmddyy.TXT, can not continue.",!

 +6        IF +IBZ

               SET IBX=""

               FOR 

                   SET IBX=$ORDER(IBY(IBX))

                   if IBX=""

                       QUIT 

                   WRITE ?30,$PIECE(IBX,";",1),!

 +7        QUIT IBZ

 +8       ;

NDCSET(X) ; parse NDC number:  raw form from VMS file is 11 numbers, parsed to 5n-4n-2n

 +1        NEW Y

           SET Y=""

           SET Y=$EXTRACT(X,1,5)_"-"_$EXTRACT(X,6,9)_"-"_$EXTRACT(X,10,11)

 +2        QUIT Y