IBCEP9B.m

IBCEP9B ;ALB/TMP - UPDATE OF PROVIDER ID FROM FILE UTILITIES ;14-NOV-00

 ;;2.0;INTEGRATED BILLING;**137,200,320**;21-MAR-94

 ;

 Q

 ;

READFILE ; Read records stored in ^TMP($J

 ;

 N D,DA,DIC,IBCT,IBP,IBQUIT,IBS,IBX,P,P3,X,Y,Z

 S (IBCT,IBQUIT,IBQUIT1,IBS)=0

 U IO(0)

 ;

 F  S IBCT=$O(^TMP($J,IBCT)) Q:'IBCT  S X=$G(^(IBCT)) I X'="" D  Q:IBQUIT

 . D  Q:IBQUIT

 .. I $P($G(IBPOS),U)="D" D

 ... D CSV(X,.IBX,$P(IBPOS,U,2),$P(IBPOS,U,3))

 ... D DSETUP(.IBX,.IBPOS,.P) K IBX

 .. I $P($G(IBPOS),U)'="D" D FSETUP(X,.IBPOS,.P)

 . ;

 . I $G(P(1))'="" S P(1)=$$NOPUNCT^IBCEF(P(1),1),X=P(1),D="SSN",DIC="^VA(200,",DIC(0)="" D IX^DIC

 . S IBP=+Y,IBVNAME=$P(Y,U,2)

 . I $S($G(P(1))="":1,1:Y'>0) D  Q

 .. S ^TMP("IBPID-ERR",$J,1,$S($G(P(1))'="":P(1),1:"NO SSN"),$G(P(2))_" ","??")=""

 .. N IBID

 .. S IBID=$S(IBFT=0!(IBFT=1):$G(P("INST_ID")),1:$G(P("PROF_ID")))

 .. S ^TMP("IBPID-ERR",$J,1,$S($G(P(1))'="":P(1),1:"NO SSN"),$G(P(2))_" ","PROV ID")=IBID

 . ;

 . S ^TMP("IBPID_IN",$J,U,IBP)=P(1)_U_P(2)_U_IBVNAME

 . F Q0=0,"TID","UPIN","INST_ID","PROF_ID","CU","CRED" S ^TMP("IBPID_IN",$J,U,IBP,Q0)=$G(P(Q0))

 Q

 ;

CSV(X,IBX,IBDEL,IBQUOTES) ; Parse out fields from a delimited file

 ; X = data string in CSV format to be parsed

 ; IBX = array returned if passed by reference, subscripted by field #

 ; IBDEL = the delimiter

 ; If IBQUOTES=1, quoted strings are double quoted within a field

 N FC,I,PC,QCT,QM,QM2,QM4,STR,TPC

 S FC=0,TPC=$L(X,IBDEL),QM=$C(34),QM2=QM_QM,QM4=QM2_QM2

 F PC=1:1:TPC D

 . S STR=$P(X,IBDEL,PC)

 . S FC=FC+1

 . I (STR=QM2)!(STR=QM4) S IBX(FC)="" Q

 . I $E(STR,1)=QM D

 .. F QCT=0:1 Q:$E(STR,QCT+1)'=QM

 .. F  Q:($E(STR,1,QCT)=$E(STR,$L(STR)-(QCT-1),$L(STR)))  S PC=PC+1 Q:PC>TPC  S STR=STR_IBDEL_$P(X,IBDEL,PC)

 .. I PC>TPC S IBX(0)="-1^UNMATCHED QUOTE MARKS" Q

 .. F  Q:$E(STR,1)'=QM  I $E(STR,$L(STR))=QM S STR=$E(STR,2,$L(STR)-1)

 . I IBQUOTES,STR[QM2 D

 .. F I=1:1:$L(STR) I $E(STR,I,I+1)=QM2 S STR=$E(STR,1,I)_$E(STR,I+2,9999)

 . S IBX(FC)=STR

 Q

 ;

MANUAL ; Manual entry to get providers from VistA

 N IBCRED,IBDA,IBNAM,IBSSN

 ; S IBCNT=0 ; this looks like extraneous code, IBCNT not used anywhere.

 F  D  I X=""!(X["^") Q

 . S Y=$$LOOKUP^XUSER Q:X=""  I X["^" S IBQUIT1=1 Q

 . S IBDA=+Y,IBNAM=$P(Y,U,2)

 . S IBSSN=$$GET1^DIQ(200,IBDA_",",9,"I")

 . S IBCRED=$$GET1^DIQ(200,IBDA_",",10.6,"I")

 . S ^TMP("IBPID_IN",$J,U,IBDA)=IBSSN_U_IBNAM_" "_IBCRED

 Q

 ;

DIR1(DIR,Z,IBQUIT,IBQUIT1) ; Ask position

 N X,Y

 S Y=$$DIR^IBCEP9(.DIR,.IBQUIT,.IBQUIT1)

 I IBQUIT1 S Y="" G DIRQ

 I $P(Z,U,4),Y'>0 S Y="",(IBQUIT1,IBQUIT)=1

 I Y'>0 S Y=""

DIRQ Q Y

 ;

DISP(Q,IBID,IBINS,IBPTYP,IBFT,IBCT,IBCU,IBPID,IBSRC) ; Display provider data

 ;  includes ID data if IBID=1

 ; Q = SSN^provider name from input^provider name from file #200

 ; IBPID = array of id numbers to be stored

 N A,IBL,Q0,Z

 S $P(Q,U,2)=$$FLEN($P(Q,U,2))

 S Q0(1)="PROVIDER : "_$P(Q,U)_$S($P(Q,U,2)'="":" ("_$P(Q,U,2)_")",1:"")_$S(IBSRC="F":" <- input file data",1:"")

 S Q0(2)="" S:IBSRC="F" Q0(2)=$J("("_$P(Q,U,3),22+$L($P(Q,U,3)))_") <- VA match"

 S IBL=0

 D DISP^IBCEP4("Q0",IBINS,IBPTYP,IBFT,IBCT,3,.IBL)

 I $G(IBCU)'="" S Q0(IBL+1)="CARE UNIT: "_IBCU

 W !

 S A=0 F  S A=$O(Q0(A)) Q:'A  W !,Q0(A)

 I $G(IBID),$O(IBPID(""))'="" D  ; Display id's to be filed

 . W ! S Z="" F  S Z=$O(IBPID(Z)) Q:Z=""  I IBPID(Z)'="" D

 .. W !,$S(Z="TID":"TAX ID NUMBER",Z="INST_ID":"INSTITUTIONAL ID",Z="PROF_ID":"PROFESSIONAL ID",Z="UPIN":"UPIN",1:"PROV ID"),": ",IBPID(Z)

 Q

 ;

DSETUP(IBX,IBPOS,P) ; Set up the subscripted array P with the correct data

 ; from IBX(pc #) based on the parameters in array IBPOS

 ; RETURNED: P(data index)=data value (pass by reference)

 N Q,Z,Z0

 S Z=$G(IBPOS("SSN")),P(1)=""

 F Z0=+Z:1:$S('$P(Z,U,2):Z,1:$P(Z,U,2)) S P(1)=P(1)_$S(P(1)'=""&($G(IBX(Z0))'=""):" ",1:"")_$G(IBX(Z0))

 S Z=$G(IBPOS("NAM")),P(2)=""

 F Z0=+Z:1:$S('$P(Z,U,2):Z,1:$P(Z,U,2)) S P(2)=P(2)_$S(P(2)'=""&($G(IBX(Z0))'=""):" ",1:"")_$G(IBX(Z0))

 F Q="TID","UPIN","INST_ID","PROF_ID","CRED","CU","LIC" D

 . S Z=$G(IBPOS(Q)),P(Q)=""

 . Q:'Z

 . F Z0=+Z:1:$S('$P(Z,U,2):Z,1:$P(Z,U,2)) S P(Q)=P(Q)_$S(P(Q)'=""&($G(IBX(Z0))'=""):" ",1:"")_$G(IBX(Z0))

 Q

 ;

FSETUP(X,IBPOS,P) ;Set up the subscripted array P with the correct data

 ; from record data in X, based on the parameters in array IBPOS for a

 ; fixed length data field format

 ; RETURNED: P(data index)=data value (pass by reference)

 ;

 N Q,Z

 S Z=$G(IBPOS("SSN")),P(1)=""

 S P(1)=$E(X,+Z,$S($P(Z,U,2):$P(Z,U,2),1:+Z))

 S Z=$G(IBPOS("NAM")),P(2)=""

 S P(2)=$E(X,+Z,$S($P(Z,U,2):$P(Z,U,2),1:+Z))

 F Q="TID","UPIN","INST_ID","PROF_ID","CRED","CU","LIC" D

 . S Z=$G(IBPOS(Q)),P(Q)=""

 . Q:'Z

 . S P(Q)=$$FLEN($E(X,+Z,$S($P(Z,U,2):$P(Z,U,2),1:+Z)))

 Q

 ;

FLEN(IBX) ; Strip out trailing spaces from field

 ; FUNCTION returns stripped data

 N Z,IB,IB1

 S IB1=IBX,IB=$TR(IB1," ")

 I IB'="" F Z=$L(IB1):-1:1 I $E(IB1,Z)'=" " S IB=$E(IB1,1,Z) Q

 Q IB

 ;

ADDID(IB200,IBINS,IBCU,IBFT,IBCT,IBPTYP,IBQUIT,IBQUIT1) ; Add ID record (file 355.9) if not already there

 N DIC,X,Y,DO,DD,DLAYGO,DIR

 S X=IB200_";VA(200,"

 S Y=+$O(^IBA(355.9,"AUNIQ",X,$S(IBINS:IBINS,1:"*ALL*"),$S($G(IBCU)'="":IBCU,1:"*N/A*"),IBFT,IBCT,IBPTYP,0))

 I 'Y D

 . S DIC(0)="L",DIC="^IBA(355.9,",DLAYGO=355.9,DIC("DR")=".02////"_IBINS_$S($G(IBCU)'="":";.03////"_IBCU,1:"")_";.04////"_IBFT_";.05////"_IBCT_";.06////"_IBPTYP

 . D FILE^DICN K DIC,DO,DD,DLAYGO

 I Y'>0 D  Q

 . S DIR(0)="AE",DIR("A",1)="A PROBLEM WAS ENCOUNTERED ADDING THIS PROVIDER ID RECORD - NO RECORD ADDED",DIR("A")="PRESS ENTER TO CONTINUE "

 . S Y=$$DIR^IBCEP9(.DIR,.IBQUIT,.IBQUIT1,,1,1)

 S IBN=Y

 Q $S(IBN>0:IBN,1:0)

 ;

PRTERR ; Prints error report

 N IBPAGE,Z,Z0,Z1,Z2,Z3,IBLCT,IBSTOP,IBHDT

 W:$E(IOST,1,2)["C-" @IOF

 I $D(^TMP("IBPID-ERR",$J)) D

 . S IBSTOP=0,IBLCT=$$HDR(.IBPAGE,.IBSTOP,.IBHDT)

 . S Z=0 F  S Z=$O(^TMP("IBPID-ERR",$J,Z)) Q:'Z  W !!,$P($T(ERR+Z^IBCEP9),";;",2)_":" D

 .. S Z0=""

 .. F  S Z0=$O(^TMP("IBPID-ERR",$J,Z,Z0)) Q:Z0=""  S IBLCT=IBLCT+1 S:(IBLCT+5)>IOSL IBLCT=$$HDR(.IBPAGE,.IBSTOP) Q:IBSTOP  D

 ... S Z1="" F  S Z1=$O(^TMP("IBPID-ERR",$J,Z,Z0,Z1)) Q:Z1=""  W !,$E(Z0_$J("",9),1,9) W:$P(Z1,U)'="" "  "_$E($P(Z1,U)_$J("",40),1,40) D

 .... S Z2="" F  S Z2=$O(^TMP("IBPID-ERR",$J,Z,Z0,Z1,Z2)) Q:Z2=""  S Z3=$G(^(Z2)) I Z3'="" D

 ..... W "  "_$S(Z2="CU":"CARE UNIT",Z2="CRED":"CREDENTIALS",Z2="TID":"TAX ID #",Z2="LIC_ST":"LICENSE STATE",Z2="LIC":"LICENSE",Z2="UPIN":"UPIN",1:Z2)_": "_Z3

FILED ; Prints all filed records

 I $D(^TMP("IBPID_IN",$J)) D

 . S IBSTOP=0,IBLCT=$$HDR(.IBPAGE,.IBSTOP,.IBHDT)

 . W !!," RECORDS SELECTED FOR FILING:"

 . S Z0=""

 . F  S Z0=$O(^TMP("IBPID_IN",$J,U,Z0)) Q:Z0=""  S IBLCT=IBLCT+1 S:(IBLCT+5)>IOSL IBLCT=$$HDR(.IBPAGE,.IBSTOP) Q:IBSTOP  D

 .. I $G(^TMP("IBPID_IN",$J,U,Z0,0))="NO PRINT" S:IBLCT>6 IBLCT=IBLCT-1 Q

 .. S Z=^TMP("IBPID_IN",$J,U,Z0)

 .. W !,$P(Z,U,1),?12,$P(Z,U,2),?52,$G(^TMP("IBPID_IN",$J,U,Z0,"INST_ID"))

 ;

 I $E(IOST,1,2)["C-",'IBSTOP K DIR S DIR(0)="E" D ^DIR K DIR

 W @IOF

 I $D(ZTQUEUED) S ZTREQ="@"

 I '$D(ZTQUEUED) W ! D ^%ZISC

 Q

HDR(PG,IBSTOP,IBHDT) ; Prints error report header, function returns # of lines used

 ; PG = the last page # printed

 ; IBHDT = the run date of the report

 N Z,IBLCT

 S IBLCT=0

 I '$G(PG) S IBHDT="RUN DATE: "_$$FMTE^XLFDT($$NOW^XLFDT(),2)_U_"RUN BY: "_$P($G(^VA(200,+$G(IBDUZ),0)),U)

 I $G(PG),$E(IOST,1,2)["C-" K DIR S DIR(0)="E" D ^DIR K DIR S IBSTOP=('Y) G:IBSTOP HDRQ  W @IOF

 S PG=$G(PG)+1

 W $J("",23)_"BATCH UPDATE OF PROVIDER ID REPORT"_$J("",13)_"PAGE: ",PG

 W !,$J("",(80-$L($P($G(IBHDT),U)))\2),$P($G(IBHDT),U)

 W !,$J("",(80-$L($P($G(IBHDT),U,2)))\2),$P($G(IBHDT),U,2)

 W !!,"    INSURANCE CO: "_$P($G(^DIC(36,+$G(IBINS),0)),U)

 W !,"PROVIDER ID TYPE: "_$P($G(^IBE(355.97,+$G(IBPTYP),0)),U)

 W !,"       FORM TYPE: "_$$EXPAND^IBTRE(355.91,.04,$G(IBFT))

 W !,"       CARE TYPE: "_$$EXPAND^IBTRE(355.91,.05,$G(IBCT))

 S IBLCT=7

 I $G(IBCU)'="" W !,$J("",7)_"CARE UNIT: "_IBCU S IBLCT=IBLCT+1

 S Z="",$P(Z,"=",81)="",IBLCT=IBLCT+1

 W !,Z

HDRQ Q $G(IBLCT)

 ;

LOCK(IBINS) ; Lock Parent and Children up

 N IBQUIT

 S IBQUIT=0

 I $P($G(^DIC(36,IBINS,3)),U,13)="P" D

 . L +^DIC(36,IBINS):5 E  S IBQUIT=1 Q

 . N CHILD

 . S CHILD="" F  S CHILD=$O(^DIC(36,"APC",IBINS,CHILD)) Q:'+CHILD  D  Q:IBQUIT

 .. L +^DIC(36,CHILD):5 E  S IBQUIT=1

 Q IBQUIT

 ;

UNLOCK(IBINS) ; Unlock the family

 I $P($G(^DIC(36,IBINS,3)),U,13)="P" D

 . L -^DIC(36,IBINS)

 . N CHILD

 . S CHILD="" F  S CHILD=$O(^DIC(36,"APC",IBINS,CHILD)) Q:'+CHILD  D

 .. L -^DIC(36,CHILD)

 Q

 ;

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---IBCEP9B   8597     printed  Feb 18, 2025@23:38:20                                                                                                                                                                                                     Page 2

IBCEP9B   ;ALB/TMP - UPDATE OF PROVIDER ID FROM FILE UTILITIES ;14-NOV-00

 +1       ;;2.0;INTEGRATED BILLING;**137,200,320**;21-MAR-94

 +2       ;

 +3        QUIT 

 +4       ;

READFILE  ; Read records stored in ^TMP($J

 +1       ;

 +2        NEW D,DA,DIC,IBCT,IBP,IBQUIT,IBS,IBX,P,P3,X,Y,Z

 +3        SET (IBCT,IBQUIT,IBQUIT1,IBS)=0

 +4        USE IO(0)

 +5       ;

 +6        FOR 

               SET IBCT=$ORDER(^TMP($JOB,IBCT))

               if 'IBCT

                   QUIT 

               SET X=$GET(^(IBCT))

               IF X'=""

                   Begin DoDot:1

 +7                    Begin DoDot:2

 +8                        IF $PIECE($GET(IBPOS),U)="D"

                               Begin DoDot:3

 +9                                DO CSV(X,.IBX,$PIECE(IBPOS,U,2),$PIECE(IBPOS,U,3))

 +10                               DO DSETUP(.IBX,.IBPOS,.P)

                                   KILL IBX

                               End DoDot:3

 +11                       IF $PIECE($GET(IBPOS),U)'="D"

                               DO FSETUP(X,.IBPOS,.P)

                       End DoDot:2

                       if IBQUIT

                           QUIT 

 +12      ;

 +13                   IF $GET(P(1))'=""

                           SET P(1)=$$NOPUNCT^IBCEF(P(1),1)

                           SET X=P(1)

                           SET D="SSN"

                           SET DIC="^VA(200,"

                           SET DIC(0)=""

                           DO IX^DIC

 +14                   SET IBP=+Y

                       SET IBVNAME=$PIECE(Y,U,2)

 +15                   IF $SELECT($GET(P(1))="":1,1:Y'>0)

                           Begin DoDot:2

 +16                           SET ^TMP("IBPID-ERR",$JOB,1,$SELECT($GET(P(1))'="":P(1),1:"NO SSN"),$GET(P(2))_" ","??")=""

 +17                           NEW IBID

 +18                           SET IBID=$SELECT(IBFT=0!(IBFT=1):$GET(P("INST_ID")),1:$GET(P("PROF_ID")))

 +19                           SET ^TMP("IBPID-ERR",$JOB,1,$SELECT($GET(P(1))'="":P(1),1:"NO SSN"),$GET(P(2))_" ","PROV ID")=IBID

                           End DoDot:2

                           QUIT 

 +20      ;

 +21                   SET ^TMP("IBPID_IN",$JOB,U,IBP)=P(1)_U_P(2)_U_IBVNAME

 +22                   FOR Q0=0,"TID","UPIN","INST_ID","PROF_ID","CU","CRED"

                           SET ^TMP("IBPID_IN",$JOB,U,IBP,Q0)=$GET(P(Q0))

                   End DoDot:1

                   if IBQUIT

                       QUIT 

 +23       QUIT 

 +24      ;

CSV(X,IBX,IBDEL,IBQUOTES) ; Parse out fields from a delimited file

 +1       ; X = data string in CSV format to be parsed

 +2       ; IBX = array returned if passed by reference, subscripted by field #

 +3       ; IBDEL = the delimiter

 +4       ; If IBQUOTES=1, quoted strings are double quoted within a field

 +5        NEW FC,I,PC,QCT,QM,QM2,QM4,STR,TPC

 +6        SET FC=0

           SET TPC=$LENGTH(X,IBDEL)

           SET QM=$CHAR(34)

           SET QM2=QM_QM

           SET QM4=QM2_QM2

 +7        FOR PC=1:1:TPC

               Begin DoDot:1

 +8                SET STR=$PIECE(X,IBDEL,PC)

 +9                SET FC=FC+1

 +10               IF (STR=QM2)!(STR=QM4)

                       SET IBX(FC)=""

                       QUIT 

 +11               IF $EXTRACT(STR,1)=QM

                       Begin DoDot:2

 +12                       FOR QCT=0:1

                               if $EXTRACT(STR,QCT+1)'=QM

                                   QUIT 

 +13                       FOR 

                               if ($EXTRACT(STR,1,QCT)=$EXTRACT(STR,$LENGTH(STR)-(QCT-1),$LENGTH(STR)))

                                   QUIT 

                               SET PC=PC+1

                               if PC>TPC

                                   QUIT 

                               SET STR=STR_IBDEL_$PIECE(X,IBDEL,PC)

 +14                       IF PC>TPC

                               SET IBX(0)="-1^UNMATCHED QUOTE MARKS"

                               QUIT 

 +15                       FOR 

                               if $EXTRACT(STR,1)'=QM

                                   QUIT 

                               IF $EXTRACT(STR,$LENGTH(STR))=QM

                                   SET STR=$EXTRACT(STR,2,$LENGTH(STR)-1)

                       End DoDot:2

 +16               IF IBQUOTES

                       IF STR[QM2

                           Begin DoDot:2

 +17                           FOR I=1:1:$LENGTH(STR)

                                   IF $EXTRACT(STR,I,I+1)=QM2

                                       SET STR=$EXTRACT(STR,1,I)_$EXTRACT(STR,I+2,9999)

                           End DoDot:2

 +18               SET IBX(FC)=STR

               End DoDot:1

 +19       QUIT 

 +20      ;

MANUAL    ; Manual entry to get providers from VistA

 +1        NEW IBCRED,IBDA,IBNAM,IBSSN

 +2       ; S IBCNT=0 ; this looks like extraneous code, IBCNT not used anywhere.

 +3        FOR 

               Begin DoDot:1

 +4                SET Y=$$LOOKUP^XUSER

                   if X=""

                       QUIT 

                   IF X["^"

                       SET IBQUIT1=1

                       QUIT 

 +5                SET IBDA=+Y

                   SET IBNAM=$PIECE(Y,U,2)

 +6                SET IBSSN=$$GET1^DIQ(200,IBDA_",",9,"I")

 +7                SET IBCRED=$$GET1^DIQ(200,IBDA_",",10.6,"I")

 +8                SET ^TMP("IBPID_IN",$JOB,U,IBDA)=IBSSN_U_IBNAM_" "_IBCRED

               End DoDot:1

               IF X=""!(X["^")

                   QUIT 

 +9        QUIT 

 +10      ;

DIR1(DIR,Z,IBQUIT,IBQUIT1) ; Ask position

 +1        NEW X,Y

 +2        SET Y=$$DIR^IBCEP9(.DIR,.IBQUIT,.IBQUIT1)

 +3        IF IBQUIT1

               SET Y=""

               GOTO DIRQ

 +4        IF $PIECE(Z,U,4)

               IF Y'>0

                   SET Y=""

                   SET (IBQUIT1,IBQUIT)=1

 +5        IF Y'>0

               SET Y=""

DIRQ       QUIT Y

 +1       ;

DISP(Q,IBID,IBINS,IBPTYP,IBFT,IBCT,IBCU,IBPID,IBSRC) ; Display provider data

 +1       ;  includes ID data if IBID=1

 +2       ; Q = SSN^provider name from input^provider name from file #200

 +3       ; IBPID = array of id numbers to be stored

 +4        NEW A,IBL,Q0,Z

 +5        SET $PIECE(Q,U,2)=$$FLEN($PIECE(Q,U,2))

 +6        SET Q0(1)="PROVIDER : "_$PIECE(Q,U)_$SELECT($PIECE(Q,U,2)'="":" ("_$PIECE(Q,U,2)_")",1:"")_$SELECT(IBSRC="F":" <- input file data",1:"")

 +7        SET Q0(2)=""

           if IBSRC="F"

               SET Q0(2)=$JUSTIFY("("_$PIECE(Q,U,3),22+$LENGTH($PIECE(Q,U,3)))_") <- VA match"

 +8        SET IBL=0

 +9        DO DISP^IBCEP4("Q0",IBINS,IBPTYP,IBFT,IBCT,3,.IBL)

 +10       IF $GET(IBCU)'=""

               SET Q0(IBL+1)="CARE UNIT: "_IBCU

 +11       WRITE !

 +12       SET A=0

           FOR 

               SET A=$ORDER(Q0(A))

               if 'A

                   QUIT 

               WRITE !,Q0(A)

 +13      ; Display id's to be filed

           IF $GET(IBID)

               IF $ORDER(IBPID(""))'=""

                   Begin DoDot:1

 +14                   WRITE !

                       SET Z=""

                       FOR 

                           SET Z=$ORDER(IBPID(Z))

                           if Z=""

                               QUIT 

                           IF IBPID(Z)'=""

                               Begin DoDot:2

 +15                               WRITE !,$SELECT(Z="TID":"TAX ID NUMBER",Z="INST_ID":"INSTITUTIONAL ID",Z="PROF_ID":"PROFESSIONAL ID",Z="UPIN":"UPIN",1:"PROV ID"),": ",IBPID(Z)

                               End DoDot:2

                   End DoDot:1

 +16       QUIT 

 +17      ;

DSETUP(IBX,IBPOS,P) ; Set up the subscripted array P with the correct data

 +1       ; from IBX(pc #) based on the parameters in array IBPOS

 +2       ; RETURNED: P(data index)=data value (pass by reference)

 +3        NEW Q,Z,Z0

 +4        SET Z=$GET(IBPOS("SSN"))

           SET P(1)=""

 +5        FOR Z0=+Z:1:$SELECT('$PIECE(Z,U,2):Z,1:$PIECE(Z,U,2))

               SET P(1)=P(1)_$SELECT(P(1)'=""&($GET(IBX(Z0))'=""):" ",1:"")_$GET(IBX(Z0))

 +6        SET Z=$GET(IBPOS("NAM"))

           SET P(2)=""

 +7        FOR Z0=+Z:1:$SELECT('$PIECE(Z,U,2):Z,1:$PIECE(Z,U,2))

               SET P(2)=P(2)_$SELECT(P(2)'=""&($GET(IBX(Z0))'=""):" ",1:"")_$GET(IBX(Z0))

 +8        FOR Q="TID","UPIN","INST_ID","PROF_ID","CRED","CU","LIC"

               Begin DoDot:1

 +9                SET Z=$GET(IBPOS(Q))

                   SET P(Q)=""

 +10               if 'Z

                       QUIT 

 +11               FOR Z0=+Z:1:$SELECT('$PIECE(Z,U,2):Z,1:$PIECE(Z,U,2))

                       SET P(Q)=P(Q)_$SELECT(P(Q)'=""&($GET(IBX(Z0))'=""):" ",1:"")_$GET(IBX(Z0))

               End DoDot:1

 +12       QUIT 

 +13      ;

FSETUP(X,IBPOS,P) ;Set up the subscripted array P with the correct data

 +1       ; from record data in X, based on the parameters in array IBPOS for a

 +2       ; fixed length data field format

 +3       ; RETURNED: P(data index)=data value (pass by reference)

 +4       ;

 +5        NEW Q,Z

 +6        SET Z=$GET(IBPOS("SSN"))

           SET P(1)=""

 +7        SET P(1)=$EXTRACT(X,+Z,$SELECT($PIECE(Z,U,2):$PIECE(Z,U,2),1:+Z))

 +8        SET Z=$GET(IBPOS("NAM"))

           SET P(2)=""

 +9        SET P(2)=$EXTRACT(X,+Z,$SELECT($PIECE(Z,U,2):$PIECE(Z,U,2),1:+Z))

 +10       FOR Q="TID","UPIN","INST_ID","PROF_ID","CRED","CU","LIC"

               Begin DoDot:1

 +11               SET Z=$GET(IBPOS(Q))

                   SET P(Q)=""

 +12               if 'Z

                       QUIT 

 +13               SET P(Q)=$$FLEN($EXTRACT(X,+Z,$SELECT($PIECE(Z,U,2):$PIECE(Z,U,2),1:+Z)))

               End DoDot:1

 +14       QUIT 

 +15      ;

FLEN(IBX) ; Strip out trailing spaces from field

 +1       ; FUNCTION returns stripped data

 +2        NEW Z,IB,IB1

 +3        SET IB1=IBX

           SET IB=$TRANSLATE(IB1," ")

 +4        IF IB'=""

               FOR Z=$LENGTH(IB1):-1:1

                   IF $EXTRACT(IB1,Z)'=" "

                       SET IB=$EXTRACT(IB1,1,Z)

                       QUIT 

 +5        QUIT IB

 +6       ;

ADDID(IB200,IBINS,IBCU,IBFT,IBCT,IBPTYP,IBQUIT,IBQUIT1) ; Add ID record (file 355.9) if not already there

 +1        NEW DIC,X,Y,DO,DD,DLAYGO,DIR

 +2        SET X=IB200_";VA(200,"

 +3        SET Y=+$ORDER(^IBA(355.9,"AUNIQ",X,$SELECT(IBINS:IBINS,1:"*ALL*"),$SELECT($GET(IBCU)'="":IBCU,1:"*N/A*"),IBFT,IBCT,IBPTYP,0))

 +4        IF 'Y

               Begin DoDot:1

 +5                SET DIC(0)="L"

                   SET DIC="^IBA(355.9,"

                   SET DLAYGO=355.9

                   SET DIC("DR")=".02////"_IBINS_$SELECT($GET(IBCU)'="":";.03////"_IBCU,1:"")_";.04////"_IBFT_";.05////"_IBCT_";.06////"_IBPTYP

 +6                DO FILE^DICN

                   KILL DIC,DO,DD,DLAYGO

               End DoDot:1

 +7        IF Y'>0

               Begin DoDot:1

 +8                SET DIR(0)="AE"

                   SET DIR("A",1)="A PROBLEM WAS ENCOUNTERED ADDING THIS PROVIDER ID RECORD - NO RECORD ADDED"

                   SET DIR("A")="PRESS ENTER TO CONTINUE "

 +9                SET Y=$$DIR^IBCEP9(.DIR,.IBQUIT,.IBQUIT1,,1,1)

               End DoDot:1

               QUIT 

 +10       SET IBN=Y

 +11       QUIT $SELECT(IBN>0:IBN,1:0)

 +12      ;

PRTERR    ; Prints error report

 +1        NEW IBPAGE,Z,Z0,Z1,Z2,Z3,IBLCT,IBSTOP,IBHDT

 +2        if $EXTRACT(IOST,1,2)["C-"

               WRITE @IOF

 +3        IF $DATA(^TMP("IBPID-ERR",$JOB))

               Begin DoDot:1

 +4                SET IBSTOP=0

                   SET IBLCT=$$HDR(.IBPAGE,.IBSTOP,.IBHDT)

 +5                SET Z=0

                   FOR 

                       SET Z=$ORDER(^TMP("IBPID-ERR",$JOB,Z))

                       if 'Z

                           QUIT 

                       WRITE !!,$PIECE($TEXT(ERR+Z^IBCEP9),";;",2)_":"

                       Begin DoDot:2

 +6                        SET Z0=""

 +7                        FOR 

                               SET Z0=$ORDER(^TMP("IBPID-ERR",$JOB,Z,Z0))

                               if Z0=""

                                   QUIT 

                               SET IBLCT=IBLCT+1

                               if (IBLCT+5)>IOSL

                                   SET IBLCT=$$HDR(.IBPAGE,.IBSTOP)

                               if IBSTOP

                                   QUIT 

                               Begin DoDot:3

 +8                                SET Z1=""

                                   FOR 

                                       SET Z1=$ORDER(^TMP("IBPID-ERR",$JOB,Z,Z0,Z1))

                                       if Z1=""

                                           QUIT 

                                       WRITE !,$EXTRACT(Z0_$JUSTIFY("",9),1,9)

                                       if $PIECE(Z1,U)'=""

                                           WRITE "  "_$EXTRACT($PIECE(Z1,U)_$JUSTIFY("",40),1,40)

                                       Begin DoDot:4

 +9                                        SET Z2=""

                                           FOR 

                                               SET Z2=$ORDER(^TMP("IBPID-ERR",$JOB,Z,Z0,Z1,Z2))

                                               if Z2=""

                                                   QUIT 

                                               SET Z3=$GET(^(Z2))

                                               IF Z3'=""

                                                   Begin DoDot:5

 +10                                                   WRITE "  "_$SELECT(Z2="CU":"CARE UNIT",Z2="CRED":"CREDENTIALS",Z2="TID":"TAX ID #",Z2="LIC_ST":"LICENSE STATE",Z2="LIC":"LICENSE",Z2="UPIN":"UPIN",1:Z2)_": "_Z3

                                                   End DoDot:5

                                       End DoDot:4

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

FILED     ; Prints all filed records

 +1        IF $DATA(^TMP("IBPID_IN",$JOB))

               Begin DoDot:1

 +2                SET IBSTOP=0

                   SET IBLCT=$$HDR(.IBPAGE,.IBSTOP,.IBHDT)

 +3                WRITE !!," RECORDS SELECTED FOR FILING:"

 +4                SET Z0=""

 +5                FOR 

                       SET Z0=$ORDER(^TMP("IBPID_IN",$JOB,U,Z0))

                       if Z0=""

                           QUIT 

                       SET IBLCT=IBLCT+1

                       if (IBLCT+5)>IOSL