IBCEP9 ;ALB/TMP - MASS UPDATE OF PROVIDER ID FROM FILE OR MANUAL ;08-NOV-00
;;2.0;INTEGRATED BILLING;**137,200,320,348,349,592**;21-MAR-94;Build 58
;;Per VA Directive 6402, this routine should not be modified.
;
EN ; Get parameters and mass input provider id by ins co
N A,DA,DIC,DIE,DIK,DIR,DR,POP,Q,Q0,X,Y,Y3,Z,Z0
N IBCND,IBCU,IBCT,IBDELIM,IBFILE,IBFILEN,IBFILEP,IBFORMAT
N IBFT,IBINFILE,IBINS,IBL,IBN,IBOK,IBOPEN,IBPOS,IBPT,IBQUIT
N IBQUIT1,IBQUOTES,IBRA,IBS,IBSA,IBSTART,IBSRC,IBVERIFY,IBVNAME
K ^TMP("IBPID_IN",$J),^TMP("IBPID-ERR",$J),^TMP("IBPID",$J)
S IBQUIT=0
1 ; Select INSURANCE COMPANY NAME:
G:IBQUIT ENQ
S IBQUIT1=0
S DIC("S")="I $P($G(^DIC(36,+Y,3)),U,13)'=""C"""
S DIC(0)="AEMQ",DIC="^DIC(36," D ^DIC
I Y'>0 G ENQ
S IBINS=+Y
S IBQUIT=$$LOCK^IBCEP9B(IBINS)
I IBQUIT,$G(IBINS) D G 1
. D UNLOCK^IBCEP9B(IBINS)
. S IBINS="",IBQUIT=0
. W !!,"Unable to lock all associated insurance companies.",!,"Please try again later.",!!
;
2 ; get data source
S IBQUIT1=0
S DIR(0)="SA^M:Manual Entry;F:Entry from file"
S DIR("A")="PROVIDER ID DATA SOURCE: ",DIR("B")="Manual Entry"
S Y=$$DIR(.DIR,.IBQUIT,.IBQUIT1)
I Y=""!("FM"'[Y)!IBQUIT1 D UNLOCK^IBCEP9B(IBINS) G 1
S IBSRC=Y,IBVERIFY=0
S IBVERIFY=(Y="M")
I 'IBVERIFY D G:IBQUIT ENQ G:IBQUIT 2
. S DIR(0)="YA",DIR("A")="DO YOU WANT TO VIEW/VERIFY EACH ENTRY BEFORE IT GETS UPDATED?: "
. S Y=$$DIR(.DIR,.IBQUIT,.IBQUIT1)
. I Y=1 S IBVERIFY=1
;
G:IBSRC="M" 4
21 ; get parameters for file type
G:IBQUIT ENQ
S IBQUIT1=0
S DIR(0)="SA^D:DELIMITED;F:FIXED LENGTH",DIR("B")="D",DIR("A")="SELECT FILE FORMAT: "
S Y=$$DIR(.DIR,.IBQUIT,.IBQUIT1)
I IBQUIT1 G 2
S IBPOS=Y
I IBPOS="D" D G:IBQUIT1 21
. S DIR(0)="FA^1:1",DIR("B")=",",DIR("A")="DELIMITER CHARACTER: "
. S Y=$$DIR(.DIR,.IBQUIT,.IBQUIT1)
. Q:IBQUIT1
. S $P(IBPOS,U,2)=Y
. S DIR(0)="YA",DIR("B")="NO",DIR("A")="ARE QUOTES WITHIN A FIELD DOUBLE QUOTED?: "
. S Y=$$DIR(.DIR,.IBQUIT,.IBQUIT1,,,1)
. Q:IBQUIT1
. S $P(IBPOS,U,3)=Y
3 ; select external file name
G:IBQUIT ENQ
S IBQUIT1=0
G:IBSRC="M" 2
S DIR(0)="FA^1:60"
S DIR("A")="FILE NAME PATH: ",DIR("B")=$$PWD^%ZISH
S Y=$$DIR(.DIR,.IBQUIT,.IBQUIT1)
G:IBQUIT1 2
S IBFILEP=$P(Y,U)
S DIR(0)="FA^1:60"
S DIR("A")="FILE NAME: "
S IBSA("*")=""
S DIR("?")="^S Y3=$$LIST^%ZISH(IBFILEP,""IBSA"",""IBRA"") I Y3=1 S Y3="""" F S Y3=$O(IBRA(Y3)) Q:Y3="""" W !,Y3"
S Y=$$DIR(.DIR,.IBQUIT,.IBQUIT1,,,1)
G:IBQUIT1 2
S IBFILEN=$P(Y,U)
K ^TMP($J),IBRA,Y3
N Y S Y=$$FTG^%ZISH(IBFILEP,IBFILEN,$NA(^TMP($J,1)),2)
I Y=0 W !,"FILE ",IBFILEP,IBFILEN," COULD NOT BE FOUND OR COULD NOT BE OPENED",! G 3
S IBFILE=IO
4 ; select Provider ID Type
G:IBQUIT ENQ
S IBQUIT1=0
S DIR(0)="355.9,.06"
I IBSRC="M" S Z=$P($G(^IBE(355.97,+$$PPTYP^IBCEP0(IBINS),0)),U) S:Z'="" DIR("B")=Z
S Y=$$DIR(.DIR,.IBQUIT,.IBQUIT1)
G:Y=""!IBQUIT1 3
S IBPTYP=$P(Y,U)
5 ; select Forms Type
G:IBQUIT ENQ
S IBQUIT1=0
S DIR(0)="355.9,.04r",DIR("B")="UB-04 and CMS-1500 FORMS"
S Y=$$DIR(.DIR,.IBQUIT,.IBQUIT1)
G:IBQUIT1 4
I Y=""!("012"'[Y) G 5
S IBFT=$P(Y,U)
6 ; select Bill Care Type
G:IBQUIT ENQ
S IBQUIT1=0
S DIR(0)="355.9,.05r",DIR("B")="BOTH INPATIENT AND OUTPATIENT"
S Y=$$DIR(.DIR,.IBQUIT,.IBQUIT1)
G:IBQUIT1 5
I Y=""!("0123"'[$P(Y,U)) G 6
S IBCT=$P(Y,U)
;
S IBCND=$$CAREUN^IBCEP3(IBINS,IBPTYP,IBFT,IBCT,IBCT=3)
7 ; get Care Unit
G:IBQUIT ENQ
S IBQUIT1=0
I IBCND D G:IBQUIT1 6
. S DIR(0)="355.9,.03O"
. S Y=$$DIR(.DIR,.IBQUIT,.IBQUIT1)
. Q:IBQUIT1
. S IBCU=$P(Y,U)
. I IBCU="" W !!,$J("",22),"***** WARNING *****",!," YOU WILL NEED TO MANUALLY ENTER THE CARE UNIT FOR EACH PROVIDER",!!
;
; Manual entry to get providers from VistA
I IBSRC="M" D MANUAL^IBCEP9B G:IBQUIT1 6
; For 'OTHER' files ask position/length or delimiter/piece for data
I IBSRC="F" D I IBQUIT1 G:'IBCND 6 G 7
. F Z="PROV. SSN^SSN^15^1","PROV. NAME^NAM^30","PROV. 1500 ID^PROF_ID^15","PROV. UB-04 ID^INST_ID^15" D Q:IBQUIT1
.. I $P(IBPOS,U)'="D" D
... N X
... I IBFT=0!(IBFT=1) Q:Z["PROF_ID" I Z["INST_ID" S $P(Z,U)="PROV. ID"
... I IBFT=2 Q:Z["INST_ID"
... S DIR("A")="START POSITION OF "_$P(Z,U)_" FIELD: "
... S DIR(0)="NA"_$S($P(Z,U,4)!($P(Z,U)["PROV. ID")!($P(Z,U)["_ID"):"",1:"O")_"^1:250"
... W ! S X=$$DIR1^IBCEP9B(.DIR,Z,.IBQUIT,.IBQUIT1)
... Q:IBQUIT1
... I X>0 D
.... S IBPOS($P(Z,U,2))=X
.... S DIR("A")="LENGTH OF "_$P(Z,U)_" FIELD: "
.... S DIR(0)="NA"_$S($P(Z,U,3):"^1:"_$P(Z,U,3),1:"")
.... S X=$$DIR1^IBCEP9B(.DIR,Z,.IBQUIT,.IBQUIT1)
.... Q:IBQUIT1
.... S $P(IBPOS($P(Z,U,2)),U,2)=IBPOS($P(Z,U,2))+X-1
.. ;
.. I $P(IBPOS,U)="D" D
... I IBFT=0!(IBFT=1) Q:Z["PROF_ID" I Z["INST_ID" S $P(Z,U)="PROV. ID"
... I IBFT=2 Q:Z["INST_ID"
... W ! S DIR("A")="STARTING '"_$P(IBPOS,U,2)_"' PIECE # OF "_$P(Z,U)_" FIELD: "
... S DIR(0)="NA"_$S($P(Z,U,4)!($P(Z,U)["PROV. ID")!($P(Z,U)["_ID"):"",1:"O")
... S X=$$DIR1^IBCEP9B(.DIR,Z,.IBQUIT,.IBQUIT1)
... Q:IBQUIT1
... I X>0 D
.... S (DIR("B"),IBPOS($P(Z,U,2)))=X
.... S DIR("A")="ENDING '"_$P(IBPOS,U,2)_"' PIECE # OF "_$P(Z,U)_" FIELD: "
.... S DIR(0)="NA"_$S($P(Z,U,4):"",1:"O")_U_(IBPOS($P(Z,U,2)))_":99"
.... S DIR("?")="JUST PRESS THE ENTER KEY IF THIS FIELD IS CONTAINED IN ONLY 1 PIECE"
.... S Y=$$DIR1^IBCEP9B(.DIR,Z,.IBQUIT,.IBQUIT1)
.... Q:IBQUIT1
.... W ! I Y>0,Y'=IBPOS($P(Z,U,2)) S $P(IBPOS($P(Z,U,2)),U,2)=Y
.. ;
. Q:IBQUIT1
. D READFILE^IBCEP9B
. ;
P1 ;
S Z="" F S Z=$O(^TMP("IBPID_IN",$J,Z)) Q:Z="" S Z0=0 F S Z0=$O(^TMP("IBPID_IN",$J,Z,Z0)) Q:'Z0 S Q=$G(^(Z0)) D G:IBQUIT ENQ
. ;
. I IBSRC="M" D Q
.. D DISP^IBCEP9B(Q,0,IBINS,IBPTYP,IBFT,IBCT,$G(IBCU),,IBSRC)
.. ; Manually add IDs
.. S IBN=$$DUP(+Z0_";VA(200,",IBINS,$S($G(IBCU)'="":IBCU,1:"*N/A*"),IBFT,IBCT,IBPTYP)
.. I 'IBN D Q:IBQUIT!(IBN'>0)
... S IBN=$$ADDID^IBCEP9B(Z0,IBINS,$G(IBCU),IBFT,IBCT,IBPTYP,,.IBQUIT)
.. S DIE="^IBA(355.9,",DR=".07",DA=+IBN D ^DIE
.. I $D(Y)!($P($G(^IBA(355.9,+IBN,0)),U,7)="") D
... I $P(IBN,U,3) S DA=+IBN,DIK="^IBA(355.9," D ^DIK
... S DIR(0)="YA",DIR("B")="NO",DIR("A")="DO YOU WANT TO STOP ENTERING PROVIDER IDs?: "
... S Y=$$DIR(.DIR,.IBQUIT,.IBQUIT1,,1,1)
... I Y=1 S IBQUIT=1
.. S IBID=$P($G(^IBA(355.9,+IBN,0)),U,7)
.. S:$L(IBID) ^TMP("IBPID_IN",$J,U,Z0,"INST_ID")=IBID
.. I IBID="" K ^TMP("IBPID_IN",$J,U,Z0)
.. I IBQUIT=1 F S Z0=$O(^TMP("IBPID_IN",$J,U,Z0)) Q:Z0="" K ^TMP("IBPID_IN",$J,U,Z0) ; user wants to stop, remove all remaining names from list
. ;
. S IBOK=1
. N IBX,IBID
. M IBX=^TMP("IBPID_IN",$J,Z,Z0)
. I IBSRC="F" S IBID=$S(IBFT=0!(IBFT=1):$G(IBX("INST_ID")),1:$G(IBX("PROF_ID")))
. I $G(IBVERIFY) D ; Display record, ask OK to file id's
.. D DISP^IBCEP9B(Q,0,IBINS,IBPTYP,IBFT,IBCT,$G(IBCU),,IBSRC)
.. W !,"PROVIDER ID: ",IBID
.. S DIR("A")="OK TO FILE THIS ID FOR THIS PROVIDER?: ",DIR(0)="YA",DIR("B")="NO"
.. S Y=$$DIR(.DIR,,,,1,1)
.. I Y'=1 D Q ; Send to error array
... S IBOK=0
... S ^TMP("IBPID-ERR",$J,2,$P(IBX,U),$P(IBX,U,2)_" ","PROV ID")=IBID
... S ^TMP("IBPID_IN",$J,U,Z0,0)="NO PRINT"
... N Z1
... S Z1="" F S Z1=$O(IBX(Z1)) Q:Z1="" I $G(IBX(Z1))'="",Z1'["_ID" S ^TMP("IBPID-ERR",$J,2,$P(IBX,U),$P(IBX,U,2)_" ",Z1)=IBX(Z1)
. I IBOK D ; Add/update the record
.. I IBSRC="F" D
... I IBID'="" D
.... S IBN=$$ADDID^IBCEP9B(+Z0,IBINS,$G(IBCU),IBFT,IBCT,IBPTYP,,.IBQUIT)
.... I IBQUIT D:IBN>0 Q
..... S DA=+IBN,DIK="^IBA(355.9," D ^DIK
.... I IBN>0 S DIE="^IBA(355.9,",DA=+IBN,DR=".07////"_IBID D ^DIE
.. ;
;
ENQ ; Print report, exit
I $G(IBINS) D
. D COPY^IBCEPCID(IBINS)
. D UNLOCK^IBCEP9B(IBINS)
;
I ($D(^TMP("IBPID-ERR",$J)))!($D(^TMP("IBPID_IN",$J))) D
. N %ZIS,ZTSAVE,ZTRTN,ZTDESC,IBDUZ
. S IBDUZ=$G(DUZ)
. S %ZIS="QM" D ^%ZIS Q:POP
. I $D(IO("Q")) K IO("Q") D D ^%ZTLOAD K ZTSK D HOME^%ZIS Q
.. S ZTRTN="PRTERR^IBCEP9B",ZTSAVE("^TMP(""IBPID-ERR"",$J,")=""
.. S ZTSAVE("^TMP(""IBPID_IN"",$J,")="",ZTSAVE("IB*")=""
.. S ZTDESC="IB - PROVIDER ID BATCH UPDATE ERROR LOG"
. U IO
. D PRTERR^IBCEP9B
K ^TMP("IBPID_IN",$J),^TMP("IBPID-ERR",$J),^TMP("IBPID",$J)
U IO(0)
Q
;
DUP(IBPRV,IBINS,IBCU,IBFT,IBCT,IBPTYP) ; Check if provider id record already exists in file 355.9
Q +$O(^IBA(355.9,"AUNIQ",IBPRV,IBINS,IBCU,IBFT,IBCT,IBPTYP,0))
;
ERREOF ; Traps EOF error on file read for non-DSM systems
N IBERROR S IBERROR=$$EC^%ZOSV
I IBERROR["ENDOFFILE" D CLOSE(.IBOPEN) G ENQ
D ^%ZTER
Q
;
CLOSE(IBOPEN) ; Close file
D CLOSE^%ZISH("IBINFILE") S IBOPEN=0
Q
;
DIR(DIR,IBQUIT,IBQUIT1,X,IBW1,IBW2) ; Standard call to ^DIR
; Inputs DIR array
; Returns IBQUIT,IBQUIT1,X if passed by reference
; AND
; FUNCTION returns the value of Y
; IBW1 = 1 if initial write ! should be done
; IBW2 = 1 if last write ! should be done
N DIROUT,DTOUT,DUOUT,DA
W:$G(IBW1) ! D ^DIR K DIR W:$G(IBW2) !
S (IBQUIT,IBQUIT1)=0
S DIR("?")="Enter '^' to back up one prompt or '^^' to exit the option"
I $D(DIROUT) S (IBQUIT,IBQUIT1)=1
I $D(DTOUT)!$D(DUOUT) S IBQUIT1=1
Q Y
;
ERR ; Error list
;; INVALID OR MISSING SSN - NO PROVIDER MATCH FOUND
;; NO UPDATE PER USER REQUEST
;;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEP9 9199 printed Oct 16, 2024@18:12:35 Page 2
IBCEP9 ;ALB/TMP - MASS UPDATE OF PROVIDER ID FROM FILE OR MANUAL ;08-NOV-00
+1 ;;2.0;INTEGRATED BILLING;**137,200,320,348,349,592**;21-MAR-94;Build 58
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
EN ; Get parameters and mass input provider id by ins co
+1 NEW A,DA,DIC,DIE,DIK,DIR,DR,POP,Q,Q0,X,Y,Y3,Z,Z0
+2 NEW IBCND,IBCU,IBCT,IBDELIM,IBFILE,IBFILEN,IBFILEP,IBFORMAT
+3 NEW IBFT,IBINFILE,IBINS,IBL,IBN,IBOK,IBOPEN,IBPOS,IBPT,IBQUIT
+4 NEW IBQUIT1,IBQUOTES,IBRA,IBS,IBSA,IBSTART,IBSRC,IBVERIFY,IBVNAME
+5 KILL ^TMP("IBPID_IN",$JOB),^TMP("IBPID-ERR",$JOB),^TMP("IBPID",$JOB)
+6 SET IBQUIT=0
1 ; Select INSURANCE COMPANY NAME:
+1 if IBQUIT
GOTO ENQ
+2 SET IBQUIT1=0
+3 SET DIC("S")="I $P($G(^DIC(36,+Y,3)),U,13)'=""C"""
+4 SET DIC(0)="AEMQ"
SET DIC="^DIC(36,"
DO ^DIC
+5 IF Y'>0
GOTO ENQ
+6 SET IBINS=+Y
+7 SET IBQUIT=$$LOCK^IBCEP9B(IBINS)
+8 IF IBQUIT
IF $GET(IBINS)
Begin DoDot:1
+9 DO UNLOCK^IBCEP9B(IBINS)
+10 SET IBINS=""
SET IBQUIT=0
+11 WRITE !!,"Unable to lock all associated insurance companies.",!,"Please try again later.",!!
End DoDot:1
GOTO 1
+12 ;
2 ; get data source
+1 SET IBQUIT1=0
+2 SET DIR(0)="SA^M:Manual Entry;F:Entry from file"
+3 SET DIR("A")="PROVIDER ID DATA SOURCE: "
SET DIR("B")="Manual Entry"
+4 SET Y=$$DIR(.DIR,.IBQUIT,.IBQUIT1)
+5 IF Y=""!("FM"'[Y)!IBQUIT1
DO UNLOCK^IBCEP9B(IBINS)
GOTO 1
+6 SET IBSRC=Y
SET IBVERIFY=0
+7 SET IBVERIFY=(Y="M")
+8 IF 'IBVERIFY
Begin DoDot:1
+9 SET DIR(0)="YA"
SET DIR("A")="DO YOU WANT TO VIEW/VERIFY EACH ENTRY BEFORE IT GETS UPDATED?: "
+10 SET Y=$$DIR(.DIR,.IBQUIT,.IBQUIT1)
+11 IF Y=1
SET IBVERIFY=1
End DoDot:1
if IBQUIT
GOTO ENQ
if IBQUIT
GOTO 2
+12 ;
+13 if IBSRC="M"
GOTO 4
21 ; get parameters for file type
+1 if IBQUIT
GOTO ENQ
+2 SET IBQUIT1=0
+3 SET DIR(0)="SA^D:DELIMITED;F:FIXED LENGTH"
SET DIR("B")="D"
SET DIR("A")="SELECT FILE FORMAT: "
+4 SET Y=$$DIR(.DIR,.IBQUIT,.IBQUIT1)
+5 IF IBQUIT1
GOTO 2
+6 SET IBPOS=Y
+7 IF IBPOS="D"
Begin DoDot:1
+8 SET DIR(0)="FA^1:1"
SET DIR("B")=","
SET DIR("A")="DELIMITER CHARACTER: "
+9 SET Y=$$DIR(.DIR,.IBQUIT,.IBQUIT1)
+10 if IBQUIT1
QUIT
+11 SET $PIECE(IBPOS,U,2)=Y
+12 SET DIR(0)="YA"
SET DIR("B")="NO"
SET DIR("A")="ARE QUOTES WITHIN A FIELD DOUBLE QUOTED?: "
+13 SET Y=$$DIR(.DIR,.IBQUIT,.IBQUIT1,,,1)
+14 if IBQUIT1
QUIT
+15 SET $PIECE(IBPOS,U,3)=Y
End DoDot:1
if IBQUIT1
GOTO 21
3 ; select external file name
+1 if IBQUIT
GOTO ENQ
+2 SET IBQUIT1=0
+3 if IBSRC="M"
GOTO 2
+4 SET DIR(0)="FA^1:60"
+5 SET DIR("A")="FILE NAME PATH: "
SET DIR("B")=$$PWD^%ZISH
+6 SET Y=$$DIR(.DIR,.IBQUIT,.IBQUIT1)
+7 if IBQUIT1
GOTO 2
+8 SET IBFILEP=$PIECE(Y,U)
+9 SET DIR(0)="FA^1:60"
+10 SET DIR("A")="FILE NAME: "
+11 SET IBSA("*")=""
+12 SET DIR("?")="^S Y3=$$LIST^%ZISH(IBFILEP,""IBSA"",""IBRA"") I Y3=1 S Y3="""" F S Y3=$O(IBRA(Y3)) Q:Y3="""" W !,Y3"
+13 SET Y=$$DIR(.DIR,.IBQUIT,.IBQUIT1,,,1)
+14 if IBQUIT1
GOTO 2
+15 SET IBFILEN=$PIECE(Y,U)
+16 KILL ^TMP($JOB),IBRA,Y3
+17 NEW Y
SET Y=$$FTG^%ZISH(IBFILEP,IBFILEN,$NAME(^TMP($JOB,1)),2)
+18 IF Y=0
WRITE !,"FILE ",IBFILEP,IBFILEN," COULD NOT BE FOUND OR COULD NOT BE OPENED",!
GOTO 3
+19 SET IBFILE=IO
4 ; select Provider ID Type
+1 if IBQUIT
GOTO ENQ
+2 SET IBQUIT1=0
+3 SET DIR(0)="355.9,.06"
+4 IF IBSRC="M"
SET Z=$PIECE($GET(^IBE(355.97,+$$PPTYP^IBCEP0(IBINS),0)),U)
if Z'=""
SET DIR("B")=Z
+5 SET Y=$$DIR(.DIR,.IBQUIT,.IBQUIT1)
+6 if Y=""!IBQUIT1
GOTO 3
+7 SET IBPTYP=$PIECE(Y,U)
5 ; select Forms Type
+1 if IBQUIT
GOTO ENQ
+2 SET IBQUIT1=0
+3 SET DIR(0)="355.9,.04r"
SET DIR("B")="UB-04 and CMS-1500 FORMS"
+4 SET Y=$$DIR(.DIR,.IBQUIT,.IBQUIT1)
+5 if IBQUIT1
GOTO 4
+6 IF Y=""!("012"'[Y)
GOTO 5
+7 SET IBFT=$PIECE(Y,U)
6 ; select Bill Care Type
+1 if IBQUIT
GOTO ENQ
+2 SET IBQUIT1=0
+3 SET DIR(0)="355.9,.05r"
SET DIR("B")="BOTH INPATIENT AND OUTPATIENT"
+4 SET Y=$$DIR(.DIR,.IBQUIT,.IBQUIT1)
+5 if IBQUIT1
GOTO 5
+6 IF Y=""!("0123"'[$PIECE(Y,U))
GOTO 6
+7 SET IBCT=$PIECE(Y,U)
+8 ;
+9 SET IBCND=$$CAREUN^IBCEP3(IBINS,IBPTYP,IBFT,IBCT,IBCT=3)
7 ; get Care Unit
+1 if IBQUIT
GOTO ENQ
+2 SET IBQUIT1=0
+3 IF IBCND
Begin DoDot:1
+4 SET DIR(0)="355.9,.03O"
+5 SET Y=$$DIR(.DIR,.IBQUIT,.IBQUIT1)
+6 if IBQUIT1
QUIT
+7 SET IBCU=$PIECE(Y,U)
+8 IF IBCU=""
WRITE !!,$JUSTIFY("",22),"***** WARNING *****",!," YOU WILL NEED TO MANUALLY ENTER THE CARE UNIT FOR EACH PROVIDER",!!
End DoDot:1
if IBQUIT1
GOTO 6
+9 ;
+10 ; Manual entry to get providers from VistA
+11 IF IBSRC="M"
DO MANUAL^IBCEP9B
if IBQUIT1
GOTO 6
+12 ; For 'OTHER' files ask position/length or delimiter/piece for data
+13 IF IBSRC="F"
Begin DoDot:1
+14 FOR Z="PROV. SSN^SSN^15^1","PROV. NAME^NAM^30","PROV. 1500 ID^PROF_ID^15","PROV. UB-04 ID^INST_ID^15"
Begin DoDot:2
+15 IF $PIECE(IBPOS,U)'="D"
Begin DoDot:3
+16 NEW X
+17 IF IBFT=0!(IBFT=1)
if Z["PROF_ID"
QUIT
IF Z["INST_ID"
SET $PIECE(Z,U)="PROV. ID"
+18 IF IBFT=2
if Z["INST_ID"
QUIT
+19 SET DIR("A")="START POSITION OF "_$PIECE(Z,U)_" FIELD: "
+20 SET DIR(0)="NA"_$SELECT($PIECE(Z,U,4)!($PIECE(Z,U)["PROV. ID")!($PIECE(Z,U)["_ID"):"",1:"O")_"^1:250"
+21 WRITE !
SET X=$$DIR1^IBCEP9B(.DIR,Z,.IBQUIT,.IBQUIT1)
+22 if IBQUIT1
QUIT
+23 IF X>0
Begin DoDot:4
+24 SET IBPOS($PIECE(Z,U,2))=X
+25 SET DIR("A")="LENGTH OF "_$PIECE(Z,U)_" FIELD: "
+26 SET DIR(0)="NA"_$SELECT($PIECE(Z,U,3):"^1:"_$PIECE(Z,U,3),1:"")
+27 SET X=$$DIR1^IBCEP9B(.DIR,Z,.IBQUIT,.IBQUIT1)
+28 if IBQUIT1
QUIT
+29 SET $PIECE(IBPOS($PIECE(Z,U,2)),U,2)=IBPOS($PIECE(Z,U,2))+X-1
End DoDot:4
End DoDot:3
+30 ;
+31 IF $PIECE(IBPOS,U)="D"
Begin DoDot:3
+32 IF IBFT=0!(IBFT=1)
if Z["PROF_ID"
QUIT
IF Z["INST_ID"
SET $PIECE(Z,U)="PROV. ID"
+33 IF IBFT=2
if Z["INST_ID"
QUIT
+34 WRITE !
SET DIR("A")="STARTING '"_$PIECE(IBPOS,U,2)_"' PIECE # OF "_$PIECE(Z,U)_" FIELD: "
+35 SET DIR(0)="NA"_$SELECT($PIECE(Z,U,4)!($PIECE(Z,U)["PROV. ID")!($PIECE(Z,U)["_ID"):"",1:"O")
+36 SET X=$$DIR1^IBCEP9B(.DIR,Z,.IBQUIT,.IBQUIT1)
+37 if IBQUIT1
QUIT
+38 IF X>0
Begin DoDot:4
+39 SET (DIR("B"),IBPOS($PIECE(Z,U,2)))=X
+40 SET DIR("A")="ENDING '"_$PIECE(IBPOS,U,2)_"' PIECE # OF "_$PIECE(Z,U)_" FIELD: "
+41 SET DIR(0)="NA"_$SELECT($PIECE(Z,U,4):"",1:"O")_U_(IBPOS($PIECE(Z,U,2)))_":99"
+42 SET DIR("?")="JUST PRESS THE ENTER KEY IF THIS FIELD IS CONTAINED IN ONLY 1 PIECE"
+43 SET Y=$$DIR1^IBCEP9B(.DIR,Z,.IBQUIT,.IBQUIT1)
+44 if IBQUIT1
QUIT
+45 WRITE !
IF Y>0
IF Y'=IBPOS($PIECE(Z,U,2))
SET $PIECE(IBPOS($PIECE(Z,U,2)),U,2)=Y
End DoDot:4
End DoDot:3
+46 ;
End DoDot:2
if IBQUIT1
QUIT
+47 if IBQUIT1
QUIT
+48 DO READFILE^IBCEP9B
+49 ;
End DoDot:1
IF IBQUIT1
if 'IBCND
GOTO 6
GOTO 7
P1 ;
+1 SET Z=""
FOR
SET Z=$ORDER(^TMP("IBPID_IN",$JOB,Z))
if Z=""
QUIT
SET Z0=0
FOR
SET Z0=$ORDER(^TMP("IBPID_IN",$JOB,Z,Z0))
if 'Z0
QUIT
SET Q=$GET(^(Z0))
Begin DoDot:1
+2 ;
+3 IF IBSRC="M"
Begin DoDot:2
+4 DO DISP^IBCEP9B(Q,0,IBINS,IBPTYP,IBFT,IBCT,$GET(IBCU),,IBSRC)
+5 ; Manually add IDs
+6 SET IBN=$$DUP(+Z0_";VA(200,",IBINS,$SELECT($GET(IBCU)'="":IBCU,1:"*N/A*"),IBFT,IBCT,IBPTYP)
+7 IF 'IBN
Begin DoDot:3
+8 SET IBN=$$ADDID^IBCEP9B(Z0,IBINS,$GET(IBCU),IBFT,IBCT,IBPTYP,,.IBQUIT)
End DoDot:3
if IBQUIT!(IBN'>0)
QUIT
+9 SET DIE="^IBA(355.9,"
SET DR=".07"
SET DA=+IBN
DO ^DIE
+10 IF $DATA(Y)!($PIECE($GET(^IBA(355.9,+IBN,0)),U,7)="")
Begin DoDot:3
+11 IF $PIECE(IBN,U,3)
SET DA=+IBN
SET DIK="^IBA(355.9,"
DO ^DIK
+12 SET DIR(0)="YA"
SET DIR("B")="NO"
SET DIR("A")="DO YOU WANT TO STOP ENTERING PROVIDER IDs?: "
+13 SET Y=$$DIR(.DIR,.IBQUIT,.IBQUIT1,,1,1)
+14 IF Y=1
SET IBQUIT=1
End DoDot:3
+15 SET IBID=$PIECE($GET(^IBA(355.9,+IBN,0)),U,7)
+16 if $LENGTH(IBID)
SET ^TMP("IBPID_IN",$JOB,U,Z0,"INST_ID")=IBID
+17 IF IBID=""
KILL ^TMP("IBPID_IN",$JOB,U,Z0)
+18 ; user wants to stop, remove all remaining names from list
IF IBQUIT=1
FOR
SET Z0=$ORDER(^TMP("IBPID_IN",$JOB,U,Z0))
if Z0=""
QUIT
KILL ^TMP("IBPID_IN",$JOB,U,Z0)
End DoDot:2
QUIT
+19 ;
+20 SET IBOK=1
+21 NEW IBX,IBID
+22 MERGE IBX=^TMP("IBPID_IN",$JOB,Z,Z0)
+23 IF IBSRC="F"
SET IBID=$SELECT(IBFT=0!(IBFT=1):$GET(IBX("INST_ID")),1:$GET(IBX("PROF_ID")))
+24 ; Display record, ask OK to file id's
IF $GET(IBVERIFY)
Begin DoDot:2
+25 DO DISP^IBCEP9B(Q,0,IBINS,IBPTYP,IBFT,IBCT,$GET(IBCU),,IBSRC)
+26 WRITE !,"PROVIDER ID: ",IBID
+27 SET DIR("A")="OK TO FILE THIS ID FOR THIS PROVIDER?: "
SET DIR(0)="YA"
SET DIR("B")="NO"
+28 SET Y=$$DIR(.DIR,,,,1,1)
+29 ; Send to error array
IF Y'=1
Begin DoDot:3
+30 SET IBOK=0
+31 SET ^TMP("IBPID-ERR",$JOB,2,$PIECE(IBX,U),$PIECE(IBX,U,2)_" ","PROV ID")=IBID
+32 SET ^TMP("IBPID_IN",$JOB,U,Z0,0)="NO PRINT"
+33 NEW Z1
+34 SET Z1=""
FOR
SET Z1=$ORDER(IBX(Z1))
if Z1=""
QUIT
IF $GET(IBX(Z1))'=""
IF Z1'["_ID"
SET ^TMP("IBPID-ERR",$JOB,2,$PIECE(IBX,U),$PIECE(IBX,U,2)_" ",Z1)=IBX(Z1)
End DoDot:3
QUIT
End DoDot:2
+35 ; Add/update the record
IF IBOK
Begin DoDot:2
+36 IF IBSRC="F"
Begin DoDot:3
+37 IF IBID'=""
Begin DoDot:4
+38 SET IBN=$$ADDID^IBCEP9B(+Z0,IBINS,$GET(IBCU),IBFT,IBCT,IBPTYP,,.IBQUIT)
+39 IF IBQUIT
if IBN>0
Begin DoDot:5
+40 SET DA=+IBN
SET DIK="^IBA(355.9,"
DO ^DIK
End DoDot:5
QUIT
+41 IF IBN>0
SET DIE="^IBA(355.9,"
SET DA=+IBN
SET DR=".07////"_IBID
DO ^DIE
End DoDot:4
End DoDot:3
+42 ;
End DoDot:2
End DoDot:1
if IBQUIT
GOTO ENQ
+43 ;
ENQ ; Print report, exit
+1 IF $GET(IBINS)
Begin DoDot:1
+2 DO COPY^IBCEPCID(IBINS)
+3 DO UNLOCK^IBCEP9B(IBINS)
End DoDot:1
+4 ;
+5 IF ($DATA(^TMP("IBPID-ERR",$JOB)))!($DATA(^TMP("IBPID_IN",$JOB)))
Begin DoDot:1
+6 NEW %ZIS,ZTSAVE,ZTRTN,ZTDESC,IBDUZ
+7 SET IBDUZ=$GET(DUZ)
+8 SET %ZIS="QM"
DO ^%ZIS
if POP
QUIT
+9 IF $DATA(IO("Q"))
KILL IO("Q")
Begin DoDot:2
+10 SET ZTRTN="PRTERR^IBCEP9B"
SET ZTSAVE("^TMP(""IBPID-ERR"",$J,")=""
+11 SET ZTSAVE("^TMP(""IBPID_IN"",$J,")=""
SET ZTSAVE("IB*")=""
+12 SET ZTDESC="IB - PROVIDER ID BATCH UPDATE ERROR LOG"
End DoDot:2
DO ^%ZTLOAD
KILL ZTSK
DO HOME^%ZIS
QUIT
+13 USE IO
+14 DO PRTERR^IBCEP9B
End DoDot:1
+15 KILL ^TMP("IBPID_IN",$JOB),^TMP("IBPID-ERR",$JOB),^TMP("IBPID",$JOB)
+16 USE IO(0)
+17 QUIT
+18 ;
DUP(IBPRV,IBINS,IBCU,IBFT,IBCT,IBPTYP) ; Check if provider id record already exists in file 355.9
+1 QUIT +$ORDER(^IBA(355.9,"AUNIQ",IBPRV,IBINS,IBCU,IBFT,IBCT,IBPTYP,0))
+2 ;
ERREOF ; Traps EOF error on file read for non-DSM systems
+1 NEW IBERROR
SET IBERROR=$$EC^%ZOSV
+2 IF IBERROR["ENDOFFILE"
DO CLOSE(.IBOPEN)
GOTO ENQ
+3 DO ^%ZTER
+4 QUIT
+5 ;
CLOSE(IBOPEN) ; Close file
+1 DO CLOSE^%ZISH("IBINFILE")
SET IBOPEN=0
+2 QUIT
+3 ;
DIR(DIR,IBQUIT,IBQUIT1,X,IBW1,IBW2) ; Standard call to ^DIR
+1 ; Inputs DIR array
+2 ; Returns IBQUIT,IBQUIT1,X if passed by reference
+3 ; AND
+4 ; FUNCTION returns the value of Y
+5 ; IBW1 = 1 if initial write ! should be done
+6 ; IBW2 = 1 if last write ! should be done
+7 NEW DIROUT,DTOUT,DUOUT,DA
+8 if $GET(IBW1)
WRITE !
DO ^DIR
KILL DIR
if $GET(IBW2)
WRITE !
+9 SET (IBQUIT,IBQUIT1)=0
+10 SET DIR("?")="Enter '^' to back up one prompt or '^^' to exit the option"
+11 IF $DATA(DIROUT)
SET (IBQUIT,IBQUIT1)=1
+12 IF $DATA(DTOUT)!$DATA(DUOUT)
SET IBQUIT1=1
+13 QUIT Y
+14 ;
ERR ; Error list
+1 ;; INVALID OR MISSING SSN - NO PROVIDER MATCH FOUND
+2 ;; NO UPDATE PER USER REQUEST
+3 ;;
