- 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 Feb 18, 2025@24:00 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)