Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBCEP9

IBCEP9.m

Go to the documentation of this file. 
  1. 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
  1.  ;;Per VA Directive 6402, this routine should not be modified.
  1.  ;
  1. EN ; Get parameters and mass input provider id by ins co
  1.  N A,DA,DIC,DIE,DIK,DIR,DR,POP,Q,Q0,X,Y,Y3,Z,Z0
  1.  N IBCND,IBCU,IBCT,IBDELIM,IBFILE,IBFILEN,IBFILEP,IBFORMAT
  1.  N IBFT,IBINFILE,IBINS,IBL,IBN,IBOK,IBOPEN,IBPOS,IBPT,IBQUIT
  1.  N IBQUIT1,IBQUOTES,IBRA,IBS,IBSA,IBSTART,IBSRC,IBVERIFY,IBVNAME
  1.  K ^TMP("IBPID_IN",$J),^TMP("IBPID-ERR",$J),^TMP("IBPID",$J)
  1.  S IBQUIT=0
  1. 1 ; Select INSURANCE COMPANY NAME:
  1.  G:IBQUIT ENQ
  1.  S IBQUIT1=0
  1.  S DIC("S")="I $P($G(^DIC(36,+Y,3)),U,13)'=""C"""
  1.  S DIC(0)="AEMQ",DIC="^DIC(36," D ^DIC
  1.  I Y'>0 G ENQ
  1.  S IBINS=+Y
  1.  S IBQUIT=$$LOCK^IBCEP9B(IBINS)
  1.  I IBQUIT,$G(IBINS) D  G 1
  1.  . D UNLOCK^IBCEP9B(IBINS)
  1.  . S IBINS="",IBQUIT=0
  1.  . W !!,"Unable to lock all associated insurance companies.",!,"Please try again later.",!!
  1.  ;
  1. 2 ; get data source
  1.  S IBQUIT1=0
  1.  S DIR(0)="SA^M:Manual Entry;F:Entry from file"
  1.  S DIR("A")="PROVIDER ID DATA SOURCE: ",DIR("B")="Manual Entry"
  1.  S Y=$$DIR(.DIR,.IBQUIT,.IBQUIT1)
  1.  I Y=""!("FM"'[Y)!IBQUIT1 D UNLOCK^IBCEP9B(IBINS) G 1
  1.  S IBSRC=Y,IBVERIFY=0
  1.  S IBVERIFY=(Y="M")
  1.  I 'IBVERIFY D  G:IBQUIT ENQ G:IBQUIT 2
  1.  . S DIR(0)="YA",DIR("A")="DO YOU WANT TO VIEW/VERIFY EACH ENTRY BEFORE IT GETS UPDATED?: "
  1.  . S Y=$$DIR(.DIR,.IBQUIT,.IBQUIT1)
  1.  . I Y=1 S IBVERIFY=1
  1.  ;
  1.  G:IBSRC="M" 4
  1. 21 ; get parameters for file type
  1.  G:IBQUIT ENQ
  1.  S IBQUIT1=0
  1.  S DIR(0)="SA^D:DELIMITED;F:FIXED LENGTH",DIR("B")="D",DIR("A")="SELECT FILE FORMAT: "
  1.  S Y=$$DIR(.DIR,.IBQUIT,.IBQUIT1)
  1.  I IBQUIT1 G 2
  1.  S IBPOS=Y
  1.  I IBPOS="D" D  G:IBQUIT1 21
  1.  . S DIR(0)="FA^1:1",DIR("B")=",",DIR("A")="DELIMITER CHARACTER: "
  1.  . S Y=$$DIR(.DIR,.IBQUIT,.IBQUIT1)
  1.  . Q:IBQUIT1
  1.  . S $P(IBPOS,U,2)=Y
  1.  . S DIR(0)="YA",DIR("B")="NO",DIR("A")="ARE QUOTES WITHIN A FIELD DOUBLE QUOTED?: "
  1.  . S Y=$$DIR(.DIR,.IBQUIT,.IBQUIT1,,,1)
  1.  . Q:IBQUIT1
  1.  . S $P(IBPOS,U,3)=Y
  1. 3 ; select external file name
  1.  G:IBQUIT ENQ
  1.  S IBQUIT1=0
  1.  G:IBSRC="M" 2
  1.  S DIR(0)="FA^1:60"
  1.  S DIR("A")="FILE NAME PATH: ",DIR("B")=$$PWD^%ZISH
  1.  S Y=$$DIR(.DIR,.IBQUIT,.IBQUIT1)
  1.  G:IBQUIT1 2
  1.  S IBFILEP=$P(Y,U)
  1.  S DIR(0)="FA^1:60"
  1.  S DIR("A")="FILE NAME: "
  1.  S IBSA("*")=""
  1.  S DIR("?")="^S Y3=$$LIST^%ZISH(IBFILEP,""IBSA"",""IBRA"") I Y3=1 S Y3="""" F  S Y3=$O(IBRA(Y3)) Q:Y3=""""  W !,Y3"
  1.  S Y=$$DIR(.DIR,.IBQUIT,.IBQUIT1,,,1)
  1.  G:IBQUIT1 2
  1.  S IBFILEN=$P(Y,U)
  1.  K ^TMP($J),IBRA,Y3
  1.  N Y S Y=$$FTG^%ZISH(IBFILEP,IBFILEN,$NA(^TMP($J,1)),2)
  1.  I Y=0 W !,"FILE ",IBFILEP,IBFILEN," COULD NOT BE FOUND OR COULD NOT BE OPENED",! G 3
  1.  S IBFILE=IO
  1. 4 ; select Provider ID Type
  1.  G:IBQUIT ENQ
  1.  S IBQUIT1=0
  1.  S DIR(0)="355.9,.06"
  1.  I IBSRC="M" S Z=$P($G(^IBE(355.97,+$$PPTYP^IBCEP0(IBINS),0)),U) S:Z'="" DIR("B")=Z
  1.  S Y=$$DIR(.DIR,.IBQUIT,.IBQUIT1)
  1.  G:Y=""!IBQUIT1 3
  1.  S IBPTYP=$P(Y,U)
  1. 5 ; select Forms Type
  1.  G:IBQUIT ENQ
  1.  S IBQUIT1=0
  1.  S DIR(0)="355.9,.04r",DIR("B")="UB-04 and CMS-1500 FORMS"
  1.  S Y=$$DIR(.DIR,.IBQUIT,.IBQUIT1)
  1.  G:IBQUIT1 4
  1.  I Y=""!("012"'[Y) G 5
  1.  S IBFT=$P(Y,U)
  1. 6 ; select Bill Care Type
  1.  G:IBQUIT ENQ
  1.  S IBQUIT1=0
  1.  S DIR(0)="355.9,.05r",DIR("B")="BOTH INPATIENT AND OUTPATIENT"
  1.  S Y=$$DIR(.DIR,.IBQUIT,.IBQUIT1)
  1.  G:IBQUIT1 5
  1.  I Y=""!("0123"'[$P(Y,U)) G 6
  1.  S IBCT=$P(Y,U)
  1.  ;
  1.  S IBCND=$$CAREUN^IBCEP3(IBINS,IBPTYP,IBFT,IBCT,IBCT=3)
  1. 7 ; get Care Unit
  1.  G:IBQUIT ENQ
  1.  S IBQUIT1=0
  1.  I IBCND D  G:IBQUIT1 6
  1.  . S DIR(0)="355.9,.03O"
  1.  . S Y=$$DIR(.DIR,.IBQUIT,.IBQUIT1)
  1.  . Q:IBQUIT1
  1.  . S IBCU=$P(Y,U)
  1.  . I IBCU="" W !!,$J("",22),"***** WARNING *****",!," YOU WILL NEED TO MANUALLY ENTER THE CARE UNIT FOR EACH PROVIDER",!!
  1.  ;
  1.  ; Manual entry to get providers from VistA
  1.  I IBSRC="M" D MANUAL^IBCEP9B G:IBQUIT1 6
  1.  ; For 'OTHER' files ask position/length or delimiter/piece for data
  1.  I IBSRC="F" D  I IBQUIT1 G:'IBCND 6 G 7
  1.  . 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
  1.  .. I $P(IBPOS,U)'="D" D
  1.  ... N X
  1.  ... I IBFT=0!(IBFT=1) Q:Z["PROF_ID"  I Z["INST_ID" S $P(Z,U)="PROV. ID"
  1.  ... I IBFT=2 Q:Z["INST_ID"
  1.  ... S DIR("A")="START POSITION OF "_$P(Z,U)_" FIELD: "
  1.  ... S DIR(0)="NA"_$S($P(Z,U,4)!($P(Z,U)["PROV. ID")!($P(Z,U)["_ID"):"",1:"O")_"^1:250"
  1.  ... W ! S X=$$DIR1^IBCEP9B(.DIR,Z,.IBQUIT,.IBQUIT1)
  1.  ... Q:IBQUIT1
  1.  ... I X>0 D
  1.  .... S IBPOS($P(Z,U,2))=X
  1.  .... S DIR("A")="LENGTH OF "_$P(Z,U)_" FIELD: "
  1.  .... S DIR(0)="NA"_$S($P(Z,U,3):"^1:"_$P(Z,U,3),1:"")
  1.  .... S X=$$DIR1^IBCEP9B(.DIR,Z,.IBQUIT,.IBQUIT1)
  1.  .... Q:IBQUIT1
  1.  .... S $P(IBPOS($P(Z,U,2)),U,2)=IBPOS($P(Z,U,2))+X-1
  1.  .. ;
  1.  .. I $P(IBPOS,U)="D" D
  1.  ... I IBFT=0!(IBFT=1) Q:Z["PROF_ID"  I Z["INST_ID" S $P(Z,U)="PROV. ID"
  1.  ... I IBFT=2 Q:Z["INST_ID"
  1.  ... W ! S DIR("A")="STARTING '"_$P(IBPOS,U,2)_"' PIECE # OF "_$P(Z,U)_" FIELD: "
  1.  ... S DIR(0)="NA"_$S($P(Z,U,4)!($P(Z,U)["PROV. ID")!($P(Z,U)["_ID"):"",1:"O")
  1.  ... S X=$$DIR1^IBCEP9B(.DIR,Z,.IBQUIT,.IBQUIT1)
  1.  ... Q:IBQUIT1
  1.  ... I X>0 D
  1.  .... S (DIR("B"),IBPOS($P(Z,U,2)))=X
  1.  .... S DIR("A")="ENDING '"_$P(IBPOS,U,2)_"' PIECE # OF "_$P(Z,U)_" FIELD: "
  1.  .... S DIR(0)="NA"_$S($P(Z,U,4):"",1:"O")_U_(IBPOS($P(Z,U,2)))_":99"
  1.  .... S DIR("?")="JUST PRESS THE ENTER KEY IF THIS FIELD IS CONTAINED IN ONLY 1 PIECE"
  1.  .... S Y=$$DIR1^IBCEP9B(.DIR,Z,.IBQUIT,.IBQUIT1)
  1.  .... Q:IBQUIT1
  1.  .... W ! I Y>0,Y'=IBPOS($P(Z,U,2)) S $P(IBPOS($P(Z,U,2)),U,2)=Y
  1.  .. ;
  1.  . Q:IBQUIT1
  1.  . D READFILE^IBCEP9B
  1.  . ;
  1. P1 ;
  1.  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
  1.  . ;
  1.  . I IBSRC="M" D  Q
  1.  .. D DISP^IBCEP9B(Q,0,IBINS,IBPTYP,IBFT,IBCT,$G(IBCU),,IBSRC)
  1.  .. ; Manually add IDs
  1.  .. S IBN=$$DUP(+Z0_";VA(200,",IBINS,$S($G(IBCU)'="":IBCU,1:"*N/A*"),IBFT,IBCT,IBPTYP)
  1.  .. I 'IBN D  Q:IBQUIT!(IBN'>0)
  1.  ... S IBN=$$ADDID^IBCEP9B(Z0,IBINS,$G(IBCU),IBFT,IBCT,IBPTYP,,.IBQUIT)
  1.  .. S DIE="^IBA(355.9,",DR=".07",DA=+IBN D ^DIE
  1.  .. I $D(Y)!($P($G(^IBA(355.9,+IBN,0)),U,7)="") D
  1.  ... I $P(IBN,U,3) S DA=+IBN,DIK="^IBA(355.9," D ^DIK
  1.  ... S DIR(0)="YA",DIR("B")="NO",DIR("A")="DO YOU WANT TO STOP ENTERING PROVIDER IDs?: "
  1.  ... S Y=$$DIR(.DIR,.IBQUIT,.IBQUIT1,,1,1)
  1.  ... I Y=1 S IBQUIT=1
  1.  .. S IBID=$P($G(^IBA(355.9,+IBN,0)),U,7)
  1.  .. S:$L(IBID) ^TMP("IBPID_IN",$J,U,Z0,"INST_ID")=IBID
  1.  .. I IBID="" K ^TMP("IBPID_IN",$J,U,Z0)
  1.  .. 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
  1.  . ;
  1.  . S IBOK=1
  1.  . N IBX,IBID
  1.  . M IBX=^TMP("IBPID_IN",$J,Z,Z0)
  1.  . I IBSRC="F" S IBID=$S(IBFT=0!(IBFT=1):$G(IBX("INST_ID")),1:$G(IBX("PROF_ID")))
  1.  . I $G(IBVERIFY) D  ; Display record, ask OK to file id's
  1.  .. D DISP^IBCEP9B(Q,0,IBINS,IBPTYP,IBFT,IBCT,$G(IBCU),,IBSRC)
  1.  .. W !,"PROVIDER ID: ",IBID
  1.  .. S DIR("A")="OK TO FILE THIS ID FOR THIS PROVIDER?: ",DIR(0)="YA",DIR("B")="NO"
  1.  .. S Y=$$DIR(.DIR,,,,1,1)
  1.  .. I Y'=1 D  Q  ; Send to error array
  1.  ... S IBOK=0
  1.  ... S ^TMP("IBPID-ERR",$J,2,$P(IBX,U),$P(IBX,U,2)_" ","PROV ID")=IBID
  1.  ... S ^TMP("IBPID_IN",$J,U,Z0,0)="NO PRINT"
  1.  ... N Z1
  1.  ... 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)
  1.  . I IBOK D  ; Add/update the record
  1.  .. I IBSRC="F" D
  1.  ... I IBID'="" D
  1.  .... S IBN=$$ADDID^IBCEP9B(+Z0,IBINS,$G(IBCU),IBFT,IBCT,IBPTYP,,.IBQUIT)
  1.  .... I IBQUIT D:IBN>0  Q
  1.  ..... S DA=+IBN,DIK="^IBA(355.9," D ^DIK
  1.  .... I IBN>0 S DIE="^IBA(355.9,",DA=+IBN,DR=".07////"_IBID D ^DIE
  1.  .. ;
  1.  ;
  1. ENQ ; Print report, exit
  1.  I $G(IBINS) D
  1.  . D COPY^IBCEPCID(IBINS)
  1.  . D UNLOCK^IBCEP9B(IBINS)
  1.  ;
  1.  I ($D(^TMP("IBPID-ERR",$J)))!($D(^TMP("IBPID_IN",$J))) D
  1.  . N %ZIS,ZTSAVE,ZTRTN,ZTDESC,IBDUZ
  1.  . S IBDUZ=$G(DUZ)
  1.  . S %ZIS="QM" D ^%ZIS Q:POP
  1.  . I $D(IO("Q")) K IO("Q") D  D ^%ZTLOAD K ZTSK D HOME^%ZIS Q
  1.  .. S ZTRTN="PRTERR^IBCEP9B",ZTSAVE("^TMP(""IBPID-ERR"",$J,")=""
  1.  .. S ZTSAVE("^TMP(""IBPID_IN"",$J,")="",ZTSAVE("IB*")=""
  1.  .. S ZTDESC="IB - PROVIDER ID BATCH UPDATE ERROR LOG"
  1.  . U IO
  1.  . D PRTERR^IBCEP9B
  1.  K ^TMP("IBPID_IN",$J),^TMP("IBPID-ERR",$J),^TMP("IBPID",$J)
  1.  U IO(0)
  1.  Q
  1.  ;
  1. DUP(IBPRV,IBINS,IBCU,IBFT,IBCT,IBPTYP) ; Check if provider id record already exists in file 355.9
  1.  Q +$O(^IBA(355.9,"AUNIQ",IBPRV,IBINS,IBCU,IBFT,IBCT,IBPTYP,0))
  1.  ;
  1. ERREOF ; Traps EOF error on file read for non-DSM systems
  1.  N IBERROR S IBERROR=$$EC^%ZOSV
  1.  I IBERROR["ENDOFFILE" D CLOSE(.IBOPEN) G ENQ
  1.  D ^%ZTER
  1.  Q
  1.  ;
  1. CLOSE(IBOPEN) ; Close file
  1.  D CLOSE^%ZISH("IBINFILE") S IBOPEN=0
  1.  Q
  1.  ;
  1. DIR(DIR,IBQUIT,IBQUIT1,X,IBW1,IBW2) ; Standard call to ^DIR
  1.  ;  Inputs DIR array
  1.  ;  Returns IBQUIT,IBQUIT1,X if passed by reference
  1.  ;    AND
  1.  ;      FUNCTION returns the value of Y
  1.  ;  IBW1 = 1 if initial write ! should be done
  1.  ;  IBW2 = 1 if last write ! should be done
  1.  N DIROUT,DTOUT,DUOUT,DA
  1.  W:$G(IBW1) ! D ^DIR K DIR W:$G(IBW2) !
  1.  S (IBQUIT,IBQUIT1)=0
  1.  S DIR("?")="Enter '^' to back up one prompt or '^^' to exit the option"
  1.  I $D(DIROUT) S (IBQUIT,IBQUIT1)=1
  1.  I $D(DTOUT)!$D(DUOUT) S IBQUIT1=1
  1.  Q Y
  1.  ;
  1. ERR ; Error list
  1.  ;; INVALID OR MISSING SSN - NO PROVIDER MATCH FOUND
  1.  ;; NO UPDATE PER USER REQUEST
  1.  ;;