IBY232PO ;ALB/BSL - IB*2*232 POST-INSTALL ;25-AUG-03
;;2.0;INTEGRATED BILLING;**232**;21-MAR-94
;
N DIC,DIK,DA,Y,X
D BMES^XPDUTL("Post-Installation Updates")
;
IBSITE ;CHANGE LIVE AND TEST QUEUE IN IB SITE PARAMETERS FILE
S $P(^IBE(350.9,1,8),"^",1)="MCH" ;LIVE QUEUE
;S $P(^IBE(350.9,1,8),"^",1)="G.MCH@ISC-ALBANY.DOMAIN.EXT" ;LIVE QUEUE
S $P(^IBE(350.9,1,8),"^",9)="G.MCH@ISC-ALBANY.DOMAIN.EXT" ;TEST QUEUE
;SAVE 8 NODE OF IB SITE PARAMETERS
;S ^XTMP("P232","NEW",INC,"350.9",8)=^IBE(350.9,1,8)
;
;S ^XTMP("P232","NEW",0)=(INC+1)
;
MAIL ;REMOTE MEMBER IN MAIL GROUP IS SAME AS IN MCR
N IBMCR,IBMCH,DLAYGO,DIC,DIK,DA,D0,DD,Z,Z0 ; IA 4439
S IBMCR=+$O(^XMB(3.8,"B","MCR",0)),IBMCH=+$O(^XMB(3.8,"B","MCH",0)) S Z=0 F S Z=$O(^XMB(3.8,IBMCR,6,Z)) Q:'Z S Z0=$P($G(^XMB(3.8,IBMCR,6,Z,0)),U) I Z0'="" D
. I '$D(^XMB(3.8,IBMCH,6,"B",Z0)) D
.. S DLAYGO=3.812,DIC(0)="L",X=Z0,DA(1)=IBMCH,DIC="^XMB(3.8,"_DA(1)_",6," D FILE^DICN K DO,DD,DA,DLAYGO,DIC
.. I Y>0 S DA(1)=IBMCR,DA=Z,DIK="^XMB(3.8,"_DA(1)_",6," D ^DIK
;
D BMES^XPDUTL("Updating facility provider ids for all insurance companies")
N DO,DD,DLAYGO,DIC,X,Y,Z,Z0,Z00,Z11,Z17,IBINS,IBID,IBHCFA,IBUB
S IBID=$$BF^IBCU()
I IBID S IBINS=0 F S IBINS=$O(^DIC(36,IBINS)) Q:'IBINS S Z11=$P($G(^(IBINS,0)),U,11),Z17=$P($G(^(0)),U,17) D
. S (IBHCFA,IBUB)=0
. S Z0=0 F S Z0=$O(^IBA(355.92,"B",IBINS,Z0)) Q:'Z0 S Z00=$G(^IBA(355.92,Z0,0)) D Q:IBHCFA&IBUB
.. I $P(Z00,U,6)=IBID S:$P(Z00,U,4)=2 IBHCFA=1 S:$P(Z00,U,4)=1 IBUB=1 Q
. I Z11'="",'IBUB S X=IBINS,DIC("DR")=".04////1;.06////"_IBID_";.07////"_Z11,DIC="^IBA(355.92,",DLAYGO=355.92,DIC(0)="L" D FILE^DICN K DO,DD,DLAYGO,DIC
. I Z17'="",'IBHCFA S X=IBINS,DIC("DR")=".04////2;.06////"_IBID_";.07////"_Z17,DIC="^IBA(355.92,",DLAYGO=355.92,DIC(0)="L" D FILE^DICN K DO,DD,DLAYGO,DIC
;
D BMES^XPDUTL("Deleting unneeded cross refs in file 399")
D DELIX^DDMOD(399,101,4),DELIX^DDMOD(399,102,5),DELIX^DDMOD(399,103,4)
I $D(^IBE(355.97,10,0)) S DA=10,DIK="^IBE(355.97," D ^DIK
I $$PROD^IBCORC,DT<3050101 D ; Production?
. N DIFROM,XMTO,XMBODY,XMSUBJ,XMZ,XMDUZ,DUZ,IBSITE,IBBODY
. D BMES^XPDUTL("SENDING EDI ENHANCEMENTS CONFIRMATION TO AUSTIN")
. S IBSITE=$$SITE^VASITE()
. S DUZ(0)="@",DUZ=.5,XMDUZ=DUZ,XMBODY="IBBODY"
. S XMSUBJ="EDI ENHANCEMENTS LOADED AT STATION #: "_$P(IBSITE,U,3)_$S($G(^XTMP("IB_EDI_ENHANCEMENTS_CONFIRMED",1)):" (AGAIN)",1:"")
. S XMTO("G.ZZ_EDIENHANCE@FO-ALBANY.DOMAIN.EXT")=""
. S IBBODY(1)="EDI ENHANCEMENTS HAS BEEN LOADED INTO THE LIVE ACCOUNT OF",IBBODY(2)=$P(IBSITE,U,2)
. D SENDMSG^XMXAPI(XMDUZ,XMSUBJ,XMBODY,.XMTO,,.XMZ)
. I $G(XMZ) S ^XTMP("IB_EDI_ENHANCEMENTS_CONFIRMED",0)="3050101^"_DT_"^EDI ENHANCEMENTS CONFIRMATION ACKNOWLEDGED",^XTMP("IB_EDI_ENHANCEMENTS_CONFIRMED",1)=XMZ
. ;
. I '$G(^XTMP("IB_EDI_ENHANCEMENTS_CONFIRMED",1)) D
.. N DIFROM,IBBODY,XMBODY,XMDUZ,XMSUBJ,XMTO,DUZ
.. S DUZ=.5,DUZ(0)="@",XMDUZ=DUZ
.. S XMBODY="IBBODY"
.. D BMES^XPDUTL("NO CONFIRMATION WAS SENT FOR INSTALL - CONTACT EVS!!!")
.. S XMSUBJ="CALL NATIONAL HELP DESK - NO EDI ENHANCEMENTS CONFIRMATION"
.. S XMTO("G.IB EDI SUPERVISOR")=""
.. S IBBODY(1)="*** IMPORTANT **** IMPORTANT **** IMPORTANT **** IMPORTANT **** IMPORTANT ***",IBBODY(2)=" "
.. S IBBODY(3)="Contact the National Help desk (EVS) IMMEDIATELY to report no confirmation",IBBODY(4)="was sent from your site for EDI Enhancements after patch IB*2*232 install."
.. D SENDMSG^XMXAPI(XMDUZ,XMSUBJ,XMBODY,.XMTO)
;
D END
Q
;
;
PEND232 ; CLEANS OUT THE ENTRIES IN THE PENDING LIST THAT
; THE PROCESS OF PARRALLEL TESTING HAS NOT ALLOWED TO RECEIVE REPORTS BACK
;
; THIS IS A TWO PART PROCESS, THE FIRST PART IDENTIFIES THE
; PENDING ENTRIES IN THE PENDING REPORT
; IF THERE ARE VALID ENTRIES IN THIS REPORT THEY SHOULD BE
; REMOVED FROM THE ^BTMP GLOBAL BEFORE PERFORMING THE SECOND
; STEP WHICH IS TO KILL ALL THE ENTRIES STILL LISTED IN ^BTMP
;
;FIND ALL THE ENTRIES IN THE ^IBA(364.1,"ASTAT","P"
S X=""
K ^BTMP(364.1)
F S X=$O(^IBA(364.1,"ASTAT","P",X)) Q:X="" D
. ; STORE IN TEMP GLOBAL ^BTMP
. ;SET BTMP TO WHAT CURRENT STATUS VALUE IS
. S ^BTMP(364.1,X)=$P($G(^IBA(364.1,X,0)),"^",2)
. ; SET CURRENT STATUS TO A0
. I $D(^BTMP(364.1,X)) S $P(^IBA(364.1,X,0),"^",2)="A0"
W !,"^BTMP GLOBAL IS PREPARED WITH PENDING ENTRIES!"
Q
;
KILLPEND ; KILL STAT ENTRY
S X=""
F S X=$O(^BTMP(364.1,X)) Q:X="" D
. K ^IBA(364.1,"ASTAT","P",X)
W !,"ALL GONE!"
Q
;
END ;
D BMES^XPDUTL("Step complete")
;
D BMES^XPDUTL("Pre-install complete")
Q
;
DELLOC ; Local form for 837 transmission - delete all local override fields
; for changed form 8 fields
N IB7,IB6,IB60,IB7X,IB7X0,Q,DA,DIK
S IB7=9999 F S IB7=$O(^IBA(364.7,IB7)) Q:'IB7 S IB6=+$G(^(IB7,0)),IB60=$G(^IBA(364.6,IB6,0)) I $P($G(^IBE(353,+IB60,2)),U,2)="T" D ; We have a transmit form o/ride
. Q:'$$INCLUDE^IBY232PR(6,+$P(IB60,U,3)) ; field is being changed
. N MES
. S MES=1,MES(1)="Removing local field from 364.6 #"_IB6_" "_$P(IB60,U,10)_" "_$P($G(^IBA(364.6,+$P(IB60,U,3),0)),U,10)
. S IB7X=0 F S IB7X=$O(^IBA(364.7,"B",IB6,IB7X)) Q:'IB7X D
. . S IB7X0=$G(^IBA(364.7,IB7X,0)) Q:IB7X0=""
. . S MES=MES+1,MES(MES)=" Override data element: "_$S(+$P(IB7X0,U,3):$$EXTERNAL^DILFD(364.7,.03,"",+$P(IB7X0,U,3)),1:"NONE DEFINED")
. . S MES=MES+1,MES(MES)=" Insurance co : "_$S($P(IB7X0,U,5):$$EXTERNAL^DILFD(364.7,.05,"",+$P(IB7X0,U,5)),1:"ALL")
. . S MES=MES+1,MES(MES)=" Bill Type : "_$S($P(IB7X0,U,6)="I":"INPATIENT",$P(IB7X0,U,6)="P":"PROFESSIONAL",1:"BOTH")
. . Q:$G(^IBA(364.7,IB7X,1))=""
. . S MES=MES+1,MES(MES)=" Override format code/description: "
. . S MES=MES+1,MES(MES)=^IBA(364.7,IB7X,1)
. . S Q=0 F S Q=$O(^IBA(364.7,IB7X,3,Q)) Q:'Q S MES=MES+1,MES(MES)=$G(^IBA(364.7,IB7X,3,Q,0))
. . S MES=MES+1,MES(MES)=" "
. . D MES^XPDUTL(.MES)
. . S DA=IB7X,DIK="^IBA(364.7," D ^DIK ; Delete entries in 364.7 for override flds
. S DIK="^IBA(364.6,",DA=IB6 D ^DIK ; delete entry in 364.6 for o/ride flds
Q
;
PRECOPY ;K ^XTMP("P232")
;I $G(^XTMP("P232",0))="" S ^XTMP("P232",0)="3040601^3030830^PATCH IB*2.0*232 SWITCH OPTION"
;I $G(^XTMP("P232","OLD",0))="" S ^XTMP("P232","OLD",0)=1
;
; CREATE INCR BACKUPS FOR RESTORE OF PREV
;N INC,N S INC=^XTMP("P232","OLD",0)
;F N=5:1:7 M ^XTMP("P232","OLD",INC,"364."_N)=^IBA("364."_N)
;
;SAVE DDs REFERENCING NEW CODE
;M ^XTMP("P232","OLD",INC,"355.9")=^DD(355.9)
;M ^XTMP("P232","OLD",INC,"355.91")=^DD(355.91)
;M ^XTMP("P232","OLD",INC,"355.92")=^DD(355.92)
;M ^XTMP("P232","OLD",INC,"355.93")=^DD(355.93)
;M ^XTMP("P232","OLD",INC,"355.97")=^DD(355.97)
;M ^XTMP("P232","OLD",INC,"399")=^DD(399)
;M ^XTMP("P232","OLD",INC,"399.0222")=^DD(399.0222)
;M ^XTMP("P232","OLD",INC,"36")=^DD(36)
;M ^XTMP("P232","OLD",INC,"2")=^DD(2)
;M ^XTMP("P232","OLD",INC,"DIC","36")=^DIC(36)
;
;SAVE 8-NODE OF 350.9
;S ^XTMP("P232","OLD",INC,"350.9",1,8)=^IBE(350.9,1,8)
;
;SAVE OLD INPUT TEMPS
;N TMPL
;S TMPL="" S TMPL=$O(^DIE("B","IB SCREEN82",TMPL))
;M ^XTMP("P232","OLD",INC,"DIE",TMPL)=^DIE(TMPL)
;S TMPL="" S TMPL=$O(^DIE("B","IB SCREEN8H",TMPL))
;M ^XTMP("P232","OLD",INC,"DIE",TMPL)=^DIE(TMPL)
;S ^XTMP("P232","OLD",0)=(INC+1)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBY232PO 7290 printed Apr 09, 2024@21:03:30 Page 2
IBY232PO ;ALB/BSL - IB*2*232 POST-INSTALL ;25-AUG-03
+1 ;;2.0;INTEGRATED BILLING;**232**;21-MAR-94
+2 ;
+3 NEW DIC,DIK,DA,Y,X
+4 DO BMES^XPDUTL("Post-Installation Updates")
+5 ;
IBSITE ;CHANGE LIVE AND TEST QUEUE IN IB SITE PARAMETERS FILE
+1 ;LIVE QUEUE
SET $PIECE(^IBE(350.9,1,8),"^",1)="MCH"
+2 ;S $P(^IBE(350.9,1,8),"^",1)="G.MCH@ISC-ALBANY.DOMAIN.EXT" ;LIVE QUEUE
+3 ;TEST QUEUE
SET $PIECE(^IBE(350.9,1,8),"^",9)="G.MCH@ISC-ALBANY.DOMAIN.EXT"
+4 ;SAVE 8 NODE OF IB SITE PARAMETERS
+5 ;S ^XTMP("P232","NEW",INC,"350.9",8)=^IBE(350.9,1,8)
+6 ;
+7 ;S ^XTMP("P232","NEW",0)=(INC+1)
+8 ;
MAIL ;REMOTE MEMBER IN MAIL GROUP IS SAME AS IN MCR
+1 ; IA 4439
NEW IBMCR,IBMCH,DLAYGO,DIC,DIK,DA,D0,DD,Z,Z0
+2 SET IBMCR=+$ORDER(^XMB(3.8,"B","MCR",0))
SET IBMCH=+$ORDER(^XMB(3.8,"B","MCH",0))
SET Z=0
FOR
SET Z=$ORDER(^XMB(3.8,IBMCR,6,Z))
if 'Z
QUIT
SET Z0=$PIECE($GET(^XMB(3.8,IBMCR,6,Z,0)),U)
IF Z0'=""
Begin DoDot:1
+3 IF '$DATA(^XMB(3.8,IBMCH,6,"B",Z0))
Begin DoDot:2
+4 SET DLAYGO=3.812
SET DIC(0)="L"
SET X=Z0
SET DA(1)=IBMCH
SET DIC="^XMB(3.8,"_DA(1)_",6,"
DO FILE^DICN
KILL DO,DD,DA,DLAYGO,DIC
+5 IF Y>0
SET DA(1)=IBMCR
SET DA=Z
SET DIK="^XMB(3.8,"_DA(1)_",6,"
DO ^DIK
End DoDot:2
End DoDot:1
+6 ;
+7 DO BMES^XPDUTL("Updating facility provider ids for all insurance companies")
+8 NEW DO,DD,DLAYGO,DIC,X,Y,Z,Z0,Z00,Z11,Z17,IBINS,IBID,IBHCFA,IBUB
+9 SET IBID=$$BF^IBCU()
+10 IF IBID
SET IBINS=0
FOR
SET IBINS=$ORDER(^DIC(36,IBINS))
if 'IBINS
QUIT
SET Z11=$PIECE($GET(^(IBINS,0)),U,11)
SET Z17=$PIECE($GET(^(0)),U,17)
Begin DoDot:1
+11 SET (IBHCFA,IBUB)=0
+12 SET Z0=0
FOR
SET Z0=$ORDER(^IBA(355.92,"B",IBINS,Z0))
if 'Z0
QUIT
SET Z00=$GET(^IBA(355.92,Z0,0))
Begin DoDot:2
+13 IF $PIECE(Z00,U,6)=IBID
if $PIECE(Z00,U,4)=2
SET IBHCFA=1
if $PIECE(Z00,U,4)=1
SET IBUB=1
QUIT
End DoDot:2
if IBHCFA&IBUB
QUIT
+14 IF Z11'=""
IF 'IBUB
SET X=IBINS
SET DIC("DR")=".04////1;.06////"_IBID_";.07////"_Z11
SET DIC="^IBA(355.92,"
SET DLAYGO=355.92
SET DIC(0)="L"
DO FILE^DICN
KILL DO,DD,DLAYGO,DIC
+15 IF Z17'=""
IF 'IBHCFA
SET X=IBINS
SET DIC("DR")=".04////2;.06////"_IBID_";.07////"_Z17
SET DIC="^IBA(355.92,"
SET DLAYGO=355.92
SET DIC(0)="L"
DO FILE^DICN
KILL DO,DD,DLAYGO,DIC
End DoDot:1
+16 ;
+17 DO BMES^XPDUTL("Deleting unneeded cross refs in file 399")
+18 DO DELIX^DDMOD(399,101,4)
DO DELIX^DDMOD(399,102,5)
DO DELIX^DDMOD(399,103,4)
+19 IF $DATA(^IBE(355.97,10,0))
SET DA=10
SET DIK="^IBE(355.97,"
DO ^DIK
+20 ; Production?
IF $$PROD^IBCORC
IF DT<3050101
Begin DoDot:1
+21 NEW DIFROM,XMTO,XMBODY,XMSUBJ,XMZ,XMDUZ,DUZ,IBSITE,IBBODY
+22 DO BMES^XPDUTL("SENDING EDI ENHANCEMENTS CONFIRMATION TO AUSTIN")
+23 SET IBSITE=$$SITE^VASITE()
+24 SET DUZ(0)="@"
SET DUZ=.5
SET XMDUZ=DUZ
SET XMBODY="IBBODY"
+25 SET XMSUBJ="EDI ENHANCEMENTS LOADED AT STATION #: "_$PIECE(IBSITE,U,3)_$SELECT($GET(^XTMP("IB_EDI_ENHANCEMENTS_CONFIRMED",1)):" (AGAIN)",1:"")
+26 SET XMTO("G.ZZ_EDIENHANCE@FO-ALBANY.DOMAIN.EXT")=""
+27 SET IBBODY(1)="EDI ENHANCEMENTS HAS BEEN LOADED INTO THE LIVE ACCOUNT OF"
SET IBBODY(2)=$PIECE(IBSITE,U,2)
+28 DO SENDMSG^XMXAPI(XMDUZ,XMSUBJ,XMBODY,.XMTO,,.XMZ)
+29 IF $GET(XMZ)
SET ^XTMP("IB_EDI_ENHANCEMENTS_CONFIRMED",0)="3050101^"_DT_"^EDI ENHANCEMENTS CONFIRMATION ACKNOWLEDGED"
SET ^XTMP("IB_EDI_ENHANCEMENTS_CONFIRMED",1)=XMZ
+30 ;
+31 IF '$GET(^XTMP("IB_EDI_ENHANCEMENTS_CONFIRMED",1))
Begin DoDot:2
+32 NEW DIFROM,IBBODY,XMBODY,XMDUZ,XMSUBJ,XMTO,DUZ
+33 SET DUZ=.5
SET DUZ(0)="@"
SET XMDUZ=DUZ
+34 SET XMBODY="IBBODY"
+35 DO BMES^XPDUTL("NO CONFIRMATION WAS SENT FOR INSTALL - CONTACT EVS!!!")
+36 SET XMSUBJ="CALL NATIONAL HELP DESK - NO EDI ENHANCEMENTS CONFIRMATION"
+37 SET XMTO("G.IB EDI SUPERVISOR")=""
+38 SET IBBODY(1)="*** IMPORTANT **** IMPORTANT **** IMPORTANT **** IMPORTANT **** IMPORTANT ***"
SET IBBODY(2)=" "
+39 SET IBBODY(3)="Contact the National Help desk (EVS) IMMEDIATELY to report no confirmation"
SET IBBODY(4)="was sent from your site for EDI Enhancements after patch IB*2*232 install."
+40 DO SENDMSG^XMXAPI(XMDUZ,XMSUBJ,XMBODY,.XMTO)
End DoDot:2
End DoDot:1
+41 ;
+42 DO END
+43 QUIT
+44 ;
+45 ;
PEND232 ; CLEANS OUT THE ENTRIES IN THE PENDING LIST THAT
+1 ; THE PROCESS OF PARRALLEL TESTING HAS NOT ALLOWED TO RECEIVE REPORTS BACK
+2 ;
+3 ; THIS IS A TWO PART PROCESS, THE FIRST PART IDENTIFIES THE
+4 ; PENDING ENTRIES IN THE PENDING REPORT
+5 ; IF THERE ARE VALID ENTRIES IN THIS REPORT THEY SHOULD BE
+6 ; REMOVED FROM THE ^BTMP GLOBAL BEFORE PERFORMING THE SECOND
+7 ; STEP WHICH IS TO KILL ALL THE ENTRIES STILL LISTED IN ^BTMP
+8 ;
+9 ;FIND ALL THE ENTRIES IN THE ^IBA(364.1,"ASTAT","P"
+10 SET X=""
+11 KILL ^BTMP(364.1)
+12 FOR
SET X=$ORDER(^IBA(364.1,"ASTAT","P",X))
if X=""
QUIT
Begin DoDot:1
+13 ; STORE IN TEMP GLOBAL ^BTMP
+14 ;SET BTMP TO WHAT CURRENT STATUS VALUE IS
+15 SET ^BTMP(364.1,X)=$PIECE($GET(^IBA(364.1,X,0)),"^",2)
+16 ; SET CURRENT STATUS TO A0
+17 IF $DATA(^BTMP(364.1,X))
SET $PIECE(^IBA(364.1,X,0),"^",2)="A0"
End DoDot:1
+18 WRITE !,"^BTMP GLOBAL IS PREPARED WITH PENDING ENTRIES!"
+19 QUIT
+20 ;
KILLPEND ; KILL STAT ENTRY
+1 SET X=""
+2 FOR
SET X=$ORDER(^BTMP(364.1,X))
if X=""
QUIT
Begin DoDot:1
+3 KILL ^IBA(364.1,"ASTAT","P",X)
End DoDot:1
+4 WRITE !,"ALL GONE!"
+5 QUIT
+6 ;
END ;
+1 DO BMES^XPDUTL("Step complete")
+2 ;
+3 DO BMES^XPDUTL("Pre-install complete")
+4 QUIT
+5 ;
DELLOC ; Local form for 837 transmission - delete all local override fields
+1 ; for changed form 8 fields
+2 NEW IB7,IB6,IB60,IB7X,IB7X0,Q,DA,DIK
+3 ; We have a transmit form o/ride
SET IB7=9999
FOR
SET IB7=$ORDER(^IBA(364.7,IB7))
if 'IB7
QUIT
SET IB6=+$GET(^(IB7,0))
SET IB60=$GET(^IBA(364.6,IB6,0))
IF $PIECE($GET(^IBE(353,+IB60,2)),U,2)="T"
Begin DoDot:1
+4 ; field is being changed
if '$$INCLUDE^IBY232PR(6,+$PIECE(IB60,U,3))
QUIT
+5 NEW MES
+6 SET MES=1
SET MES(1)="Removing local field from 364.6 #"_IB6_" "_$PIECE(IB60,U,10)_" "_$PIECE($GET(^IBA(364.6,+$PIECE(IB60,U,3),0)),U,10)
+7 SET IB7X=0
FOR
SET IB7X=$ORDER(^IBA(364.7,"B",IB6,IB7X))
if 'IB7X
QUIT
Begin DoDot:2
+8 SET IB7X0=$GET(^IBA(364.7,IB7X,0))
if IB7X0=""
QUIT
+9 SET MES=MES+1
SET MES(MES)=" Override data element: "_$SELECT(+$PIECE(IB7X0,U,3):$$EXTERNAL^DILFD(364.7,.03,"",+$PIECE(IB7X0,U,3)),1:"NONE DEFINED")
+10 SET MES=MES+1
SET MES(MES)=" Insurance co : "_$SELECT($PIECE(IB7X0,U,5):$$EXTERNAL^DILFD(364.7,.05,"",+$PIECE(IB7X0,U,5)),1:"ALL")
+11 SET MES=MES+1
SET MES(MES)=" Bill Type : "_$SELECT($PIECE(IB7X0,U,6)="I":"INPATIENT",$PIECE(IB7X0,U,6)="P":"PROFESSIONAL",1:"BOTH")
+12 if $GET(^IBA(364.7,IB7X,1))=""
QUIT
+13 SET MES=MES+1
SET MES(MES)=" Override format code/description: "
+14 SET MES=MES+1
SET MES(MES)=^IBA(364.7,IB7X,1)
+15 SET Q=0
FOR
SET Q=$ORDER(^IBA(364.7,IB7X,3,Q))
if 'Q
QUIT
SET MES=MES+1
SET MES(MES)=$GET(^IBA(364.7,IB7X,3,Q,0))
+16 SET MES=MES+1
SET MES(MES)=" "
+17 DO MES^XPDUTL(.MES)
+18 ; Delete entries in 364.7 for override flds
SET DA=IB7X
SET DIK="^IBA(364.7,"
DO ^DIK
End DoDot:2
+19 ; delete entry in 364.6 for o/ride flds
SET DIK="^IBA(364.6,"
SET DA=IB6
DO ^DIK
End DoDot:1
+20 QUIT
+21 ;
PRECOPY ;K ^XTMP("P232")
+1 ;I $G(^XTMP("P232",0))="" S ^XTMP("P232",0)="3040601^3030830^PATCH IB*2.0*232 SWITCH OPTION"
+2 ;I $G(^XTMP("P232","OLD",0))="" S ^XTMP("P232","OLD",0)=1
+3 ;
+4 ; CREATE INCR BACKUPS FOR RESTORE OF PREV
+5 ;N INC,N S INC=^XTMP("P232","OLD",0)
+6 ;F N=5:1:7 M ^XTMP("P232","OLD",INC,"364."_N)=^IBA("364."_N)
+7 ;
+8 ;SAVE DDs REFERENCING NEW CODE
+9 ;M ^XTMP("P232","OLD",INC,"355.9")=^DD(355.9)
+10 ;M ^XTMP("P232","OLD",INC,"355.91")=^DD(355.91)
+11 ;M ^XTMP("P232","OLD",INC,"355.92")=^DD(355.92)
+12 ;M ^XTMP("P232","OLD",INC,"355.93")=^DD(355.93)
+13 ;M ^XTMP("P232","OLD",INC,"355.97")=^DD(355.97)
+14 ;M ^XTMP("P232","OLD",INC,"399")=^DD(399)
+15 ;M ^XTMP("P232","OLD",INC,"399.0222")=^DD(399.0222)
+16 ;M ^XTMP("P232","OLD",INC,"36")=^DD(36)
+17 ;M ^XTMP("P232","OLD",INC,"2")=^DD(2)
+18 ;M ^XTMP("P232","OLD",INC,"DIC","36")=^DIC(36)
+19 ;
+20 ;SAVE 8-NODE OF 350.9
+21 ;S ^XTMP("P232","OLD",INC,"350.9",1,8)=^IBE(350.9,1,8)
+22 ;
+23 ;SAVE OLD INPUT TEMPS
+24 ;N TMPL
+25 ;S TMPL="" S TMPL=$O(^DIE("B","IB SCREEN82",TMPL))
+26 ;M ^XTMP("P232","OLD",INC,"DIE",TMPL)=^DIE(TMPL)
+27 ;S TMPL="" S TMPL=$O(^DIE("B","IB SCREEN8H",TMPL))
+28 ;M ^XTMP("P232","OLD",INC,"DIE",TMPL)=^DIE(TMPL)
+29 ;S ^XTMP("P232","OLD",0)=(INC+1)
