- IBCEMU3 ;ALB/ESG - MRA UTILITY - INS CO CHECKER ;14-JUNE-2004
- ;;2.0;INTEGRATED BILLING;**155**;21-MAR-94
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- Q
- ;
- INSCHK ; Check insurance company file for "rogue" Medicare WNR entries
- ; Send an email message reporting any problems
- NEW IEN,INSNAME,CNT,MSG,Z,XMTEXT,XMDUZ,XMSUB,XMY,XMDUN,XMZ,XMMG
- NEW D,D0,D1,D2,DG,DIC,DICR,DISYS,DIW,DIFROM,DA,DIK,X,Y
- NEW MCR,DATA,Z0,Z5,PCE,TOC,IBX,INACTXT
- KILL ^TMP($J,"P155")
- S IEN=0,CNT=0,MCR=0
- F S IEN=$O(^DIC(36,IEN)) Q:'IEN D
- . I '$$MCRWNR^IBEFUNC(IEN) Q ; not Medicare WNR
- . ;I $P($G(^DIC(36,IEN,0)),U,5) Q ; inactive
- . ;I $P($G(^DIC(36,IEN,5)),U,1) Q ; scheduled for deletion
- . S INSNAME=$P($G(^DIC(36,IEN,0)),U,1)
- . I INSNAME="MEDICARE (WNR)" D Q ; this is what it should be
- .. S MCR=MCR+1
- .. D MCRPRV(IEN),PROVID(IEN) ; do some stuff with MCRWNR
- .. Q
- . I INSNAME="" S INSNAME="~UNKNOWN"
- . S CNT=CNT+1
- . S ^TMP($J,"P155",1,INSNAME,IEN)=""
- . Q
- ;
- ; Either none or more than 1 Medicare WNR entries exist
- I MCR'=1 D
- . S IEN=0,INSNAME="MEDICARE (WNR)"
- . I '$D(^DIC(36,"B",INSNAME)) S ^TMP($J,"P155",2,0)="DNE" Q
- . F S IEN=$O(^DIC(36,"B",INSNAME,IEN)) Q:'IEN D
- .. S DATA="",Z0=$G(^DIC(36,IEN,0)),Z5=$G(^DIC(36,IEN,5))
- .. I $P(Z0,U,2)'="N" S $P(DATA,U,1)=$$EXTERNAL^DILFD(36,1,,$P(Z0,U,2))
- .. S TOC=$$EXTERNAL^DILFD(36,.13,,$P(Z0,U,13)) ; type of coverage
- .. I TOC'="MEDICARE" S $P(DATA,U,2)=TOC
- .. I $P(Z0,U,5) S $P(DATA,U,3)=$$EXTERNAL^DILFD(36,.05,,$P(Z0,U,5))
- .. I $P(Z5,U,1) S $P(DATA,U,4)=$$EXTERNAL^DILFD(36,5.01,,$P(Z5,U,1))
- .. S ^TMP($J,"P155",2,IEN)=DATA
- .. Q
- . Q
- ;
- ; Check the Medicare related plans
- S IBX=$$GETWNR^IBCNSMM1()
- I 'IBX S ^TMP($J,"P155",3)=IBX
- ;
- S MSG(1)="MRA has been installed at the following site:"
- I '$$VFIELD^DILFD(350.9,8.11) S MSG(1)="Pre-MRA Insurance Company checker utility from:"
- ;
- S MSG(2)=""
- S MSG(3)=" "_$P($G(^DIC(4,+$P($G(^IBE(350.9,1,0)),U,2),0)),U,1)
- S MSG(4)=" "_$G(^XMB("NETNAME"))
- S MSG(5)=" "_$$SITE^VASITE()
- S MSG(6)=""
- S MSG(7)="Version Information: "_$G(^XPD(9.7,+$O(^XPD(9.7,"B","IB*2.0*155",""),-1),2))
- S MSG(8)="",Z=8
- ;
- I '$D(^TMP($J,"P155")) D
- . S Z=Z+1,MSG(Z)="No problems detected with the set-up of MEDICARE (WNR)."
- . S Z=Z+1,MSG(Z)=""
- . Q
- ;
- I $D(^TMP($J,"P155",2)) D
- . S Z=Z+1,MSG(Z)="*** MEDICARE (WNR) IS NOT SET-UP CORRECTLY ***"
- . S Z=Z+1,MSG(Z)=""
- . ;
- . I $D(^TMP($J,"P155",2,0)) D Q
- .. S Z=Z+1,MSG(Z)=" There is no insurance company on file named ""MEDICARE (WNR)""."
- .. S Z=Z+1,MSG(Z)=""
- .. Q
- . ;
- . I MCR>1 D
- .. S Z=Z+1,MSG(Z)=" There are multiple MEDICARE (WNR) entries defined."
- .. S Z=Z+1,MSG(Z)=""
- .. Q
- . ;
- . S IEN=0
- . F S IEN=$O(^TMP($J,"P155",2,IEN)) Q:'IEN D
- .. S DATA=^TMP($J,"P155",2,IEN)
- .. S Z=Z+1,MSG(Z)=" "_$P($G(^DIC(36,IEN,0)),U,1)_" ien="_IEN
- .. I DATA="" S Z=Z+1,MSG(Z)=" VALID"
- .. F PCE=1:1:4 I $P(DATA,U,PCE)'="" D
- ... S Z=Z+1
- ... I PCE=1 S MSG(Z)="REIMBURSE?"
- ... I PCE=2 S MSG(Z)="TYPE OF COVERAGE"
- ... I PCE=3 S MSG(Z)="INACTIVE"
- ... I PCE=4 S MSG(Z)="SCHEDULED FOR DELETION"
- ... S MSG(Z)=" "_MSG(Z)_" = "_$P(DATA,U,PCE)
- ... Q
- .. S Z=Z+1,MSG(Z)=""
- .. Q
- . S Z=Z+1,MSG(Z)=""
- . Q
- ;
- I $D(^TMP($J,"P155",3)) D
- . S Z=Z+1,MSG(Z)="Additional Information:"
- . S Z=Z+1,MSG(Z)=" "_$G(^TMP($J,"P155",3))
- . S Z=Z+1,MSG(Z)=""
- . Q
- ;
- I $D(^TMP($J,"P155",1)) D
- . S Z=Z+1,MSG(Z)="The following insurance company is "
- . I CNT>1 S MSG(Z)="The following "_CNT_" insurance companies are "
- . S MSG(Z)=MSG(Z)_"incorrectly set-up like Medicare WNR:"
- . S Z=Z+1,MSG(Z)=""
- . S INSNAME=""
- . F S INSNAME=$O(^TMP($J,"P155",1,INSNAME)) Q:INSNAME="" S IEN=0 F S IEN=$O(^TMP($J,"P155",1,INSNAME,IEN)) Q:'IEN D
- .. S INACTXT=""
- .. I $P($G(^DIC(36,IEN,0)),U,5) S INACTXT="Inactive"
- .. S Z=Z+1,MSG(Z)=" "_$$LJ^XLFSTR(INSNAME,35)
- .. S MSG(Z)=MSG(Z)_$$LJ^XLFSTR(INACTXT,15)
- .. S MSG(Z)=MSG(Z)_"ien="_IEN
- .. Q
- . S Z=Z+1,MSG(Z)=""
- . S Z=Z+1,MSG(Z)="According to the VA guidelines for the Standardization of Medicare"
- . S Z=Z+1,MSG(Z)="Information, the only entry should be ""MEDICARE (WNR)""."
- . S Z=Z+1,MSG(Z)=""
- . Q
- ;
- ; Send this message to holders of the IB INSURANCE SUPERVISOR key
- S Z=Z+1,MSG(Z)="Local recipients of this message hold the IB INSURANCE SUPERVISOR key"
- S Z=Z+1,MSG(Z)=""
- S IBX=0
- F S IBX=$O(^XUSEC("IB INSURANCE SUPERVISOR",IBX)) Q:'IBX D
- . N INFO,PHONE,NAME,PHONE2
- . S INFO=$G(^VA(200,IBX,0))
- . I $P(INFO,U,7) Q ; disuser
- . I $P(INFO,U,11) Q ; termination date
- . S XMY(IBX)=""
- . S PHONE=$P($G(^VA(200,IBX,.13)),U,2)
- . S PHONE2=$P($G(^VA(200,IBX,.13)),U,5)
- . I PHONE2'="" S PHONE=PHONE_$S(PHONE'="":" / ",1:"")_PHONE2
- . I PHONE="" S PHONE="Unknown phone #"
- . S NAME=$P(INFO,U,1)
- . S Z=Z+1,MSG(Z)=" "_$$LJ^XLFSTR(NAME,40)_PHONE
- . Q
- S Z=Z+1,MSG(Z)=""
- ;
- ; MailMan variables and message sending
- S XMTEXT="MSG("
- S XMDUZ=DUZ
- S XMSUB="MEDICARE WNR ENTRIES"
- S XMY(DUZ)=""
- S XMY("michael.f.pida@us.pwc.com")=""
- S XMY("Janet.Harris2@domain.ext")=""
- S XMY("Loretta.Gulley2@domain.ext")=""
- S XMY("eric.gustafson@daou.com")=""
- ;
- D ^XMD ; send it!
- ;
- INSCHKX ;
- KILL ^TMP($J,"P155")
- Q
- ;
- MCRPRV(INSIEN) ; Update fields in the MCRWNR entry
- ; This procedure updates the Hospital Provider Number field (.11)
- ; and the Professional Provider Number field (.17) in file 36 for the
- ; MEDICARE (WNR) entry. These numbers have been assigned to the VA
- ; by Medicare.
- ;
- NEW DIE,DA,DR,D,D0,DI,DIC,DQ,X,Y
- S INSIEN=+$G(INSIEN)
- I '$D(^DIC(36,INSIEN)) G MCRPRVX
- S DIE=36,DA=INSIEN,DR=".11///670899;.17///670899"
- D ^DIE
- MCRPRVX ;
- Q
- ;
- PROVID(INSIEN) ; Add an entry to file 355.91 - IB insurance co level billing
- ; provider ID file. This is to add an entry for the UPIN of VAD000
- ; into this file for the MEDICARE (WNR) insurance company entry.
- ;
- NEW DA,DATA,DIK,DG,DIC,DICR,DIW,X,Y
- S INSIEN=+$G(INSIEN)
- I '$D(^DIC(36,INSIEN)) G PROVIDX
- S DA=0
- F S DA=$O(^IBA(355.91,"B",INSIEN,DA)) Q:'DA D
- . S DATA=$G(^IBA(355.91,DA,0))
- . I $$EXTERNAL^DILFD(355.91,.06,,$P(DATA,U,6))'="UPIN" Q
- . S DIK="^IBA(355.91," D ^DIK ; delete existing MCRWNR/upin entry
- . Q
- ;
- ; Add the new MCRWNR/upin entry
- NEW DIC,DO,DA,DINUM,X,Y,UPIN,DG,DICR,DIW
- S DIC="^IBA(355.91,",DIC(0)="F",X=INSIEN
- S UPIN=$O(^IBE(355.97,"B","UPIN",0)) I 'UPIN G PROVIDX
- S DIC("DR")=".04////0;.05////0;.06////"_UPIN_";.07////VAD000;.1////*N/A*"
- D FILE^DICN
- PROVIDX ;
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEMU3 6610 printed Jan 18, 2025@03:12:28 Page 2
- IBCEMU3 ;ALB/ESG - MRA UTILITY - INS CO CHECKER ;14-JUNE-2004
- +1 ;;2.0;INTEGRATED BILLING;**155**;21-MAR-94
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 ;
- +4 QUIT
- +5 ;
- INSCHK ; Check insurance company file for "rogue" Medicare WNR entries
- +1 ; Send an email message reporting any problems
- +2 NEW IEN,INSNAME,CNT,MSG,Z,XMTEXT,XMDUZ,XMSUB,XMY,XMDUN,XMZ,XMMG
- +3 NEW D,D0,D1,D2,DG,DIC,DICR,DISYS,DIW,DIFROM,DA,DIK,X,Y
- +4 NEW MCR,DATA,Z0,Z5,PCE,TOC,IBX,INACTXT
- +5 KILL ^TMP($JOB,"P155")
- +6 SET IEN=0
- SET CNT=0
- SET MCR=0
- +7 FOR
- SET IEN=$ORDER(^DIC(36,IEN))
- if 'IEN
- QUIT
- Begin DoDot:1
- +8 ; not Medicare WNR
- IF '$$MCRWNR^IBEFUNC(IEN)
- QUIT
- +9 ;I $P($G(^DIC(36,IEN,0)),U,5) Q ; inactive
- +10 ;I $P($G(^DIC(36,IEN,5)),U,1) Q ; scheduled for deletion
- +11 SET INSNAME=$PIECE($GET(^DIC(36,IEN,0)),U,1)
- +12 ; this is what it should be
- IF INSNAME="MEDICARE (WNR)"
- Begin DoDot:2
- +13 SET MCR=MCR+1
- +14 ; do some stuff with MCRWNR
- DO MCRPRV(IEN)
- DO PROVID(IEN)
- +15 QUIT
- End DoDot:2
- QUIT
- +16 IF INSNAME=""
- SET INSNAME="~UNKNOWN"
- +17 SET CNT=CNT+1
- +18 SET ^TMP($JOB,"P155",1,INSNAME,IEN)=""
- +19 QUIT
- End DoDot:1
- +20 ;
- +21 ; Either none or more than 1 Medicare WNR entries exist
- +22 IF MCR'=1
- Begin DoDot:1
- +23 SET IEN=0
- SET INSNAME="MEDICARE (WNR)"
- +24 IF '$DATA(^DIC(36,"B",INSNAME))
- SET ^TMP($JOB,"P155",2,0)="DNE"
- QUIT
- +25 FOR
- SET IEN=$ORDER(^DIC(36,"B",INSNAME,IEN))
- if 'IEN
- QUIT
- Begin DoDot:2
- +26 SET DATA=""
- SET Z0=$GET(^DIC(36,IEN,0))
- SET Z5=$GET(^DIC(36,IEN,5))
- +27 IF $PIECE(Z0,U,2)'="N"
- SET $PIECE(DATA,U,1)=$$EXTERNAL^DILFD(36,1,,$PIECE(Z0,U,2))
- +28 ; type of coverage
- SET TOC=$$EXTERNAL^DILFD(36,.13,,$PIECE(Z0,U,13))
- +29 IF TOC'="MEDICARE"
- SET $PIECE(DATA,U,2)=TOC
- +30 IF $PIECE(Z0,U,5)
- SET $PIECE(DATA,U,3)=$$EXTERNAL^DILFD(36,.05,,$PIECE(Z0,U,5))
- +31 IF $PIECE(Z5,U,1)
- SET $PIECE(DATA,U,4)=$$EXTERNAL^DILFD(36,5.01,,$PIECE(Z5,U,1))
- +32 SET ^TMP($JOB,"P155",2,IEN)=DATA
- +33 QUIT
- End DoDot:2
- +34 QUIT
- End DoDot:1
- +35 ;
- +36 ; Check the Medicare related plans
- +37 SET IBX=$$GETWNR^IBCNSMM1()
- +38 IF 'IBX
- SET ^TMP($JOB,"P155",3)=IBX
- +39 ;
- +40 SET MSG(1)="MRA has been installed at the following site:"
- +41 IF '$$VFIELD^DILFD(350.9,8.11)
- SET MSG(1)="Pre-MRA Insurance Company checker utility from:"
- +42 ;
- +43 SET MSG(2)=""
- +44 SET MSG(3)=" "_$PIECE($GET(^DIC(4,+$PIECE($GET(^IBE(350.9,1,0)),U,2),0)),U,1)
- +45 SET MSG(4)=" "_$GET(^XMB("NETNAME"))
- +46 SET MSG(5)=" "_$$SITE^VASITE()
- +47 SET MSG(6)=""
- +48 SET MSG(7)="Version Information: "_$GET(^XPD(9.7,+$ORDER(^XPD(9.7,"B","IB*2.0*155",""),-1),2))
- +49 SET MSG(8)=""
- SET Z=8
- +50 ;
- +51 IF '$DATA(^TMP($JOB,"P155"))
- Begin DoDot:1
- +52 SET Z=Z+1
- SET MSG(Z)="No problems detected with the set-up of MEDICARE (WNR)."
- +53 SET Z=Z+1
- SET MSG(Z)=""
- +54 QUIT
- End DoDot:1
- +55 ;
- +56 IF $DATA(^TMP($JOB,"P155",2))
- Begin DoDot:1
- +57 SET Z=Z+1
- SET MSG(Z)="*** MEDICARE (WNR) IS NOT SET-UP CORRECTLY ***"
- +58 SET Z=Z+1
- SET MSG(Z)=""
- +59 ;
- +60 IF $DATA(^TMP($JOB,"P155",2,0))
- Begin DoDot:2
- +61 SET Z=Z+1
- SET MSG(Z)=" There is no insurance company on file named ""MEDICARE (WNR)""."
- +62 SET Z=Z+1
- SET MSG(Z)=""
- +63 QUIT
- End DoDot:2
- QUIT
- +64 ;
- +65 IF MCR>1
- Begin DoDot:2
- +66 SET Z=Z+1
- SET MSG(Z)=" There are multiple MEDICARE (WNR) entries defined."
- +67 SET Z=Z+1
- SET MSG(Z)=""
- +68 QUIT
- End DoDot:2
- +69 ;
- +70 SET IEN=0
- +71 FOR
- SET IEN=$ORDER(^TMP($JOB,"P155",2,IEN))
- if 'IEN
- QUIT
- Begin DoDot:2
- +72 SET DATA=^TMP($JOB,"P155",2,IEN)
- +73 SET Z=Z+1
- SET MSG(Z)=" "_$PIECE($GET(^DIC(36,IEN,0)),U,1)_" ien="_IEN
- +74 IF DATA=""
- SET Z=Z+1
- SET MSG(Z)=" VALID"
- +75 FOR PCE=1:1:4
- IF $PIECE(DATA,U,PCE)'=""
- Begin DoDot:3
- +76 SET Z=Z+1
- +77 IF PCE=1
- SET MSG(Z)="REIMBURSE?"
- +78 IF PCE=2
- SET MSG(Z)="TYPE OF COVERAGE"
- +79 IF PCE=3
- SET MSG(Z)="INACTIVE"
- +80 IF PCE=4
- SET MSG(Z)="SCHEDULED FOR DELETION"
- +81 SET MSG(Z)=" "_MSG(Z)_" = "_$PIECE(DATA,U,PCE)
- +82 QUIT
- End DoDot:3
- +83 SET Z=Z+1
- SET MSG(Z)=""
- +84 QUIT
- End DoDot:2
- +85 SET Z=Z+1
- SET MSG(Z)=""
- +86 QUIT
- End DoDot:1
- +87 ;
- +88 IF $DATA(^TMP($JOB,"P155",3))
- Begin DoDot:1
- +89 SET Z=Z+1
- SET MSG(Z)="Additional Information:"
- +90 SET Z=Z+1
- SET MSG(Z)=" "_$GET(^TMP($JOB,"P155",3))
- +91 SET Z=Z+1
- SET MSG(Z)=""
- +92 QUIT
- End DoDot:1
- +93 ;
- +94 IF $DATA(^TMP($JOB,"P155",1))
- Begin DoDot:1
- +95 SET Z=Z+1
- SET MSG(Z)="The following insurance company is "
- +96 IF CNT>1
- SET MSG(Z)="The following "_CNT_" insurance companies are "
- +97 SET MSG(Z)=MSG(Z)_"incorrectly set-up like Medicare WNR:"
- +98 SET Z=Z+1
- SET MSG(Z)=""
- +99 SET INSNAME=""
- +100 FOR
- SET INSNAME=$ORDER(^TMP($JOB,"P155",1,INSNAME))
- if INSNAME=""
- QUIT
- SET IEN=0
- FOR
- SET IEN=$ORDER(^TMP($JOB,"P155",1,INSNAME,IEN))
- if 'IEN
- QUIT
- Begin DoDot:2
- +101 SET INACTXT=""
- +102 IF $PIECE($GET(^DIC(36,IEN,0)),U,5)
- SET INACTXT="Inactive"
- +103 SET Z=Z+1
- SET MSG(Z)=" "_$$LJ^XLFSTR(INSNAME,35)
- +104 SET MSG(Z)=MSG(Z)_$$LJ^XLFSTR(INACTXT,15)
- +105 SET MSG(Z)=MSG(Z)_"ien="_IEN
- +106 QUIT
- End DoDot:2
- +107 SET Z=Z+1
- SET MSG(Z)=""
- +108 SET Z=Z+1
- SET MSG(Z)="According to the VA guidelines for the Standardization of Medicare"
- +109 SET Z=Z+1
- SET MSG(Z)="Information, the only entry should be ""MEDICARE (WNR)""."
- +110 SET Z=Z+1
- SET MSG(Z)=""
- +111 QUIT
- End DoDot:1
- +112 ;
- +113 ; Send this message to holders of the IB INSURANCE SUPERVISOR key
- +114 SET Z=Z+1
- SET MSG(Z)="Local recipients of this message hold the IB INSURANCE SUPERVISOR key"
- +115 SET Z=Z+1
- SET MSG(Z)=""
- +116 SET IBX=0
- +117 FOR
- SET IBX=$ORDER(^XUSEC("IB INSURANCE SUPERVISOR",IBX))
- if 'IBX
- QUIT
- Begin DoDot:1
- +118 NEW INFO,PHONE,NAME,PHONE2
- +119 SET INFO=$GET(^VA(200,IBX,0))
- +120 ; disuser
- IF $PIECE(INFO,U,7)
- QUIT
- +121 ; termination date
- IF $PIECE(INFO,U,11)
- QUIT
- +122 SET XMY(IBX)=""
- +123 SET PHONE=$PIECE($GET(^VA(200,IBX,.13)),U,2)
- +124 SET PHONE2=$PIECE($GET(^VA(200,IBX,.13)),U,5)
- +125 IF PHONE2'=""
- SET PHONE=PHONE_$SELECT(PHONE'="":" / ",1:"")_PHONE2
- +126 IF PHONE=""
- SET PHONE="Unknown phone #"
- +127 SET NAME=$PIECE(INFO,U,1)
- +128 SET Z=Z+1
- SET MSG(Z)=" "_$$LJ^XLFSTR(NAME,40)_PHONE
- +129 QUIT
- End DoDot:1
- +130 SET Z=Z+1
- SET MSG(Z)=""
- +131 ;
- +132 ; MailMan variables and message sending
- +133 SET XMTEXT="MSG("
- +134 SET XMDUZ=DUZ
- +135 SET XMSUB="MEDICARE WNR ENTRIES"
- +136 SET XMY(DUZ)=""
- +137 SET XMY("michael.f.pida@us.pwc.com")=""
- +138 SET XMY("Janet.Harris2@domain.ext")=""
- +139 SET XMY("Loretta.Gulley2@domain.ext")=""
- +140 SET XMY("eric.gustafson@daou.com")=""
- +141 ;
- +142 ; send it!
- DO ^XMD
- +143 ;
- INSCHKX ;
- +1 KILL ^TMP($JOB,"P155")
- +2 QUIT
- +3 ;
- MCRPRV(INSIEN) ; Update fields in the MCRWNR entry
- +1 ; This procedure updates the Hospital Provider Number field (.11)
- +2 ; and the Professional Provider Number field (.17) in file 36 for the
- +3 ; MEDICARE (WNR) entry. These numbers have been assigned to the VA
- +4 ; by Medicare.
- +5 ;
- +6 NEW DIE,DA,DR,D,D0,DI,DIC,DQ,X,Y
- +7 SET INSIEN=+$GET(INSIEN)
- +8 IF '$DATA(^DIC(36,INSIEN))
- GOTO MCRPRVX
- +9 SET DIE=36
- SET DA=INSIEN
- SET DR=".11///670899;.17///670899"
- +10 DO ^DIE
- MCRPRVX ;
- +1 QUIT
- +2 ;
- PROVID(INSIEN) ; Add an entry to file 355.91 - IB insurance co level billing
- +1 ; provider ID file. This is to add an entry for the UPIN of VAD000
- +2 ; into this file for the MEDICARE (WNR) insurance company entry.
- +3 ;
- +4 NEW DA,DATA,DIK,DG,DIC,DICR,DIW,X,Y
- +5 SET INSIEN=+$GET(INSIEN)
- +6 IF '$DATA(^DIC(36,INSIEN))
- GOTO PROVIDX
- +7 SET DA=0
- +8 FOR
- SET DA=$ORDER(^IBA(355.91,"B",INSIEN,DA))
- if 'DA
- QUIT
- Begin DoDot:1
- +9 SET DATA=$GET(^IBA(355.91,DA,0))
- +10 IF $$EXTERNAL^DILFD(355.91,.06,,$PIECE(DATA,U,6))'="UPIN"
- QUIT
- +11 ; delete existing MCRWNR/upin entry
- SET DIK="^IBA(355.91,"
- DO ^DIK
- +12 QUIT
- End DoDot:1
- +13 ;
- +14 ; Add the new MCRWNR/upin entry
- +15 NEW DIC,DO,DA,DINUM,X,Y,UPIN,DG,DICR,DIW
- +16 SET DIC="^IBA(355.91,"
- SET DIC(0)="F"
- SET X=INSIEN
- +17 SET UPIN=$ORDER(^IBE(355.97,"B","UPIN",0))
- IF 'UPIN
- GOTO PROVIDX
- +18 SET DIC("DR")=".04////0;.05////0;.06////"_UPIN_";.07////VAD000;.1////*N/A*"
- +19 DO FILE^DICN
- PROVIDX ;
- +1 QUIT
- +2 ;