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

IBD3P63.m

Go to the documentation of this file. 
  1. IBD3P63  ;ALB/SS - POST INSTALL ROUTINE FOR IBD*3*63 ;07/26/11
  1.  ;;3.0;AUTOMATED INFO COLLECTION SYS;**63**;APR 24, 1997;Build 80
  1.  ;
  1.  Q
  1.  ;
  1. POST ; post install for IBD*3*63
  1.  N IBDBLK,IBDIPNAM,IBDI10,IBDI9,IBDRETV,IBDFRIEN,IBDEXST
  1.  D MES^XPDUTL("Starting post-install of IBD*3*63")
  1.  D MES^XPDUTL(" ")
  1.  D INACT^IBD3P63A
  1.  D MES^XPDUTL(" ")
  1.  I $$PATCH^XPDUTL("IBD*3.0*63") D MES^XPDUTL("Skipping ICD-10 Package Interface file creation. Previously installed.") Q
  1.  ;
  1.  D MES^XPDUTL("Adding an ""ICD-10 DIAGNOSIS CODE"" record to #359.1 file")
  1.  S IBDEXST=0 I $O(^IBE(359.1,"B","ICD-10 DIAGNOSIS CODE",0))>0 S IBDEXST=1 D MES^XPDUTL("Skipping - ""ICD-10 DIAGNOSIS CODE"" was added previously.")
  1.  I IBDEXST=0 I $$ADD3591()<0 D MES^XPDUTL("Error has occurred during the installation.") Q
  1.  ;
  1.  D MES^XPDUTL("Adding a ""SHORT NARRATIVE (60 CHAR)"" record to #359.1 file")
  1.  S IBDEXST=0 I $O(^IBE(359.1,"B","SHORT NARRATIVE (60 CHAR)",0))>0 S IBDEXST=1 D MES^XPDUTL("Skipping - ""SHORT NARRATIVE (60 CHAR)"" was added previously.")
  1.  I IBDEXST=0 I $$ADD3591A()<0 D MES^XPDUTL("Error has occurred during the installation.") Q
  1.  ;
  1.  D MES^XPDUTL("Adding ""INPUT DIAGNOSIS CODE (ICD10)"" record to #357.6 file")
  1.  S IBDEXST=0 I $O(^IBE(357.6,"B","INPUT DIAGNOSIS CODE (ICD10)",0))>0 S IBDEXST=1 D MES^XPDUTL("Skipping - ""INPUT DIAGNOSIS CODE (ICD10)"" was added previously.")
  1.  I IBDEXST=0 I $$ADD3576A()<0 D MES^XPDUTL("Error has occurred during the installation.") Q
  1.  ;
  1.  D MES^XPDUTL("Adding ""DG SELECT ICD-10 DIAGNOSIS CODES"" record to #357.6 file")
  1.  S IBDEXST=0 I $O(^IBE(357.6,"B","DG SELECT ICD-10 DIAGNOSIS COD",0))>0 S IBDEXST=1 D MES^XPDUTL("Skipping - ""DG SELECT ICD-10 DIAGNOSIS COD"" was added previously.")
  1.  I IBDEXST=0 I $$ADD3576B(.IBDIPNAM)<0 D MES^XPDUTL("Error has occurred during the installation.") Q
  1.  ;
  1.  D MES^XPDUTL("Adding ICD-10 blocks to both the TOOL KIT form and the DEFAULTS form.")
  1.  S IBDEXST=0 I $O(^IBE(357.1,"B","ICD-10 DIAGNOSES (V1.0)",0))>0 S IBDEXST=1 D MES^XPDUTL("Skipping - ""ICD-10 DIAGNOSES (V1.0)"" was added previously.")
  1.  I IBDEXST=0 I $$ADD3571(.IBDBLK)<0 D MES^XPDUTL("Error has occurred during the installation.") Q
  1.  I IBDEXST=0 I $$ADD3572(.IBDBLK,.IBDIPNAM)<0 D MES^XPDUTL("Error has occurred during the installation.") Q
  1.  ;
  1.  D MES^XPDUTL("Copying block to DEFAULTS form.")
  1.  S IBDFRIEN=$O(^IBE(357,"B","DEFAULTS",""))
  1.  I +IBDFRIEN=0 D MES^XPDUTL("Warning: The DEFAULTS form wasn't found.") D NODEFAUL^IBD3P63A  ;send the warning message and continue installation
  1.  I +IBDFRIEN>0 S IBDRETV=0 D  I IBDRETV<0 D MES^XPDUTL("Error has occurred during the installation.") Q
  1.  . I $$CHK10BLK^IBD3P63A(IBDFRIEN)=1 D MES^XPDUTL("Skipping - ICD-10 block was added previously to the Defaults form.") Q
  1.  . S IBDRETV=$$COPYBLK(.IBDBLK)
  1.  ;
  1.  D MES^XPDUTL("Changing block names from ""DIAGNOSIS (V2.1)"" to ""ICD-9 DIAGNOSIS (V2.1)""")
  1.  D ICD9NAME^IBD3P63A
  1.  ;
  1.  D MES^XPDUTL("Changing text in the INPUT DIAGNOSIS CODE (ICD9) record from ""Diagnosis Code"" to ""ICD-9 Diagnosis code""")
  1.  S IBDEXST=$$CHK3576^IBD3P63A()
  1.  I IBDEXST=1 D MES^XPDUTL("Skipping - text in the INPUT DIAGNOSIS CODE (ICD9) record already changed to indicate ICD-9.")
  1.  I IBDEXST=0 I $$CHNG3576^IBD3P63A()<0 D MES^XPDUTL("Error has occurred during the installation.") Q
  1.  ;
  1.  D MES^XPDUTL("Setting the Coding System flag in #357 field .22 for ICD-9 and ICD-10 Package Interfaces")
  1.  S IBDEXST=0
  1.  S IBDI9=$O(^IBE(357.6,"B","DG SELECT ICD-9 DIAGNOSIS CODE",0)) I IBDI9'="" S $P(^IBE(357.6,IBDI9,0),U,22)=1 D
  1.  . D MES^XPDUTL("Coding System set to 1 in ^IBE(357.6,"_IBDI9_",0)")
  1.  S IBDI10=$O(^IBE(357.6,"B","DG SELECT ICD-10 DIAGNOSIS COD",0)) I IBDI10'="" S $P(^IBE(357.6,IBDI10,0),U,22)=30 D
  1.  . D MES^XPDUTL("Coding System set to 30 in ^IBE(357.6,"_IBDI10_",0)")
  1.  D MES^XPDUTL("Finished pre-install of BPS*1*7")
  1.  Q
  1.  ;
  1.  ;Adding an "ICD-10 DIAGNOSIS CODE" record to 359.1 file
  1. ADD3591() ;
  1.  N IBDFLD
  1.  ;DATA TYPE
  1.  S IBDFLD(.01)="ICD-10 DIAGNOSIS CODE"
  1.  ;MAXIMUM LENGTH FOR INPUT
  1.  S IBDFLD(.02)=8 ;7 chars + decimal point = 8 chars in total: AN?.???? where A - alpha, N numeric and ? - alpha or numeric
  1.  ;PRINT FORMAT
  1.  S IBDFLD(.05)="___.____"
  1.  ;SPACE ALLOCATION
  1.  S IBDFLD(.06)=8 ;
  1.  ;REQUIRED CONFIDENCE
  1.  S IBDFLD(.07)=10 ;
  1.  ;PCE DIM VITALS TYPE
  1.  S IBDFLD(.12)="ICD10" ;
  1.  ;PCE DIM INPUT TRANSFORM
  1.  S IBDFLD(1)="D INPICD10^IBDFN8(.X)" ;
  1.  ;PAPER KEYBOARD DATA TYPE
  1.  S IBDFLD(10.01)="a"
  1.  ;PAPER KEYBOARD PICTURE
  1.  S IBDFLD(10.02)="XF"
  1.  ;PK PICTURES FOR SUBFIELDS
  1.  S IBDFLD(10.04)="ANX.XXXX"
  1.  ;
  1.  S IBDRET=$$INSREC^IBDUTIL1(359.1,"",.IBDFLD,"")
  1.  I IBDRET>0 D MES^XPDUTL("  "_IBDFLD(.01)_" has been added to the file #359.1 ") Q +IBDRET
  1.  D MES^XPDUTL("Error: "_IBDFLD(.01)_" has NOT been added to the file #359.1 ")
  1.  Q -1
  1.  ;
  1.  ;adding "SHORT NARRATIVE (60 CHAR)" to file 359.1
  1. ADD3591A() ;
  1.  N IBDFLD,IBDBORDR,IBDPOUND
  1.  S $P(IBDBORDR,"_",60)=""
  1.  S $P(IBDPOUND,"#",60)=""
  1.  ;DATA TYPE
  1.  S IBDFLD(.01)="SHORT NARRATIVE (60 CHAR)"
  1.  ;MAXIMUM LENGTH FOR INPUT
  1.  S IBDFLD(.02)=60
  1.  ;PRINT FORMAT
  1.  S IBDFLD(.05)=IBDBORDR
  1.  ;SPACE ALLOCATION
  1.  S IBDFLD(.06)=60 ;
  1.  ;REQUIRED CONFIDENCE
  1.  S IBDFLD(.07)=10 ;
  1.  ;PCE DIM VITALS TYPE
  1.  S IBDFLD(.12)="NARR" ;
  1.  ;PAPER KEYBOARD DATA TYPE
  1.  S IBDFLD(10.01)="a"
  1.  ;PK PICTURES FOR SUBFIELDS
  1.  S IBDFLD(10.04)=IBDPOUND
  1.  ;
  1.  S IBDRET=$$INSREC^IBDUTIL1(359.1,"",.IBDFLD,"")
  1.  I IBDRET>0 D MES^XPDUTL("  "_IBDFLD(.01)_" has been added to the file #359.1 ") Q +IBDRET
  1.  D MES^XPDUTL("Error: "_IBDFLD(.01)_" has NOT been added to the file #359.1 ")
  1.  Q -1
  1.  ;
  1.  ;adding "INPUT DIAGNOSIS CODE (ICD10)" to #357.6 file
  1. ADD3576A() ;
  1.  ;
  1.  N IBDFLD,IBDRET,IBDIEN10,IBDARR,IBDIEN9,IBDSUB,IBDENTRY
  1.  ;populate array
  1.  S IBDIEN9=$$ARR3576^IBD3P63("INPUT DIAGNOSIS CODE (ICD9)",.IBDFLD)
  1.  I IBDIEN9=0 D MES^XPDUTL("Error: "_IBDFLD(.01)_" has NOT been added to the file #357.6 because ICD9 record wasn't found") Q -1
  1.  ;override/set some of the fields
  1.  S (IBDFLD(.01),IBDENTRY)="INPUT DIAGNOSIS CODE (ICD10)"
  1.  ;kill description node
  1.  K IBDFLD(1)
  1.  ;
  1.  S IBDFLD(3)="INPUT ICD10 ICD-10 DIAGNOSIS CODES"
  1.  ;PCE DIM INPUT TRANSFORM: D INPICD10^IBDFN8(.X)
  1.  S IBDFLD(9)="D INPICD10^IBDFN8(.X)"
  1.  ;HELP TEXT: Enter an active ICD10 diagnosis code.
  1.  S IBDFLD(10)="Enter at least two characters of an active ICD10 diagnosis code."
  1.  ;VALIDATOR: D TESTICD0^IBDFN7
  1.  S IBDFLD(11)="D TESTICD0^IBDFN7"
  1.  ;PCE DIM OUTPUT TRANSFORM: S Y=$$DSPICD10^IBDFN9(Y)
  1.  S IBDFLD(14)="S Y=$$DSPICD10^IBDFN9(Y)"
  1.  ;SELECTOR: D SLCTDX10^IBDFN12(.X)
  1.  S IBDFLD(17)="D SLCTDX10^IBDFN12(.X)"
  1.  ;MANUAL DATA ENTRY ROUTINE: D LIST10^IBDFDE2(.IBDSEL,.IBDF,"Diagnosis Code")
  1.  S IBDFLD(18)="S IBDF(""OTHER"")=""80^I '$P(^(0),U,9)"" D LIST^IBDFDE2(.IBDSEL,.IBDF,""ICD-10 Diagnosis Code"")"
  1.  ;EXTERNAL DISPLAY VALUES: D DX10^IBDFN14(X)
  1.  S IBDFLD(19)="D DX10^IBDFN14(X)"
  1.  ;kill some other nodes
  1.  K IBDFLD(16),IBDFLD(20),IBDFLD(21)
  1.  ;create a new entry
  1.  S IBDRET=$$INSREC^IBDUTIL1(357.6,"",.IBDFLD,"")
  1.  I IBDRET<1 D MES^XPDUTL("Error: "_IBDFLD(.01)_" has NOT been added to the file #357.6 ") Q -1
  1.  D MES^XPDUTL("  "_IBDFLD(.01)_" has been added to the file #357.6 ")
  1.  S IBDIEN10=+IBDRET
  1.  ;populate DESCRIPTION
  1.  ;DESCRIPTION: Used for inputting ICD10 diagnosis codes.
  1.  S IBDARR(1,0)="Used for inputting ICD10 diagnosis codes."
  1.  S IBDRET=$$UPDWD^IBDUTIL1(357.6,IBDIEN10_",",1,"KA",.IBDARR)
  1.  I IBDRET<0 D MES^XPDUTL("Error: Description was NOT added for the"_IBDFLD(.01)_" #357.6 entry")
  1.  ;
  1.  ;get ALLOWABLE QUALIFIERS from ICD9 record
  1.  ;populate 357.613 multiple
  1.  ;
  1.  K IBDFLD,IBDARR
  1.  D U357613(IBDIEN9,.IBDARR)
  1.  S IBDSUB=0,IBDRET=1
  1.  F  S IBDSUB=$O(IBDARR(IBDSUB)) Q:+IBDSUB=0  D
  1.  . S IBDFLD(.01)=$G(IBDARR(IBDSUB,.01))
  1.  . S IBDFLD(.03)=$G(IBDARR(IBDSUB,.03))
  1.  . S IBDFLD(.08)=$G(IBDARR(IBDSUB,.08))
  1.  . S IBDRET=$$INSREC^IBDUTIL1(357.613,IBDIEN10,.IBDFLD,"")
  1.  . I IBDRET<0 D MES^XPDUTL("Error: "_IBDFLD(.01)_" ALLOWABLE QUALIFIER was NOT added for the "_IBDENTRY_" #357.6 entry") Q
  1.  . D MES^XPDUTL("  "_IBDFLD(.01)_" has been added to the #357.613 multiple")
  1.  Q 0
  1.  ;
  1.  ;adding "DG SELECT ICD-10 DIAGNOSIS CODES"
  1. ADD3576B(IBDIPNAM) ;
  1.  N IBDFLD,IBDRET,IBDIEN10,IBDARR,IBDIEN9,IBDIEN13
  1.  N IBDIEN162,IBDIEN166,IBDSUB,IBDENTRY
  1.  ;populate array
  1.  S IBDIEN9=$$ARR3576^IBD3P63("DG SELECT ICD-9 DIAGNOSIS CODES",.IBDFLD)
  1.  I IBDIEN9=0 D MES^XPDUTL("Error: "_IBDFLD(.01)_" has NOT been added to the file #357.6 because ICD9 record wasn't found") Q -1
  1.  ;override/set some of the fields
  1.  S IBDIEN13=$O(^IBE(357.6,"B","INPUT DIAGNOSIS CODE (ICD10)",""))
  1.  S (IBDFLD(.01),IBDENTRY)="DG SELECT ICD-10 DIAGNOSIS CODES"
  1.  S IBDIPNAM=$E(IBDENTRY,1,30) ;needed for file 357.2; "B" cross ref has only 30 characters.
  1.  S IBDFLD(.02)="ICD10"
  1.  S IBDFLD(.03)="IBDFN4"
  1.  S IBDFLD(.13)=IBDIEN13
  1.  ;kill description node
  1.  K IBDFLD(1)
  1.  S IBDFLD(2.01)="CODE"
  1.  S IBDFLD(2.02)=8
  1.  S IBDFLD(3)="SELECT ICD10 ICD-10 CODES DIAGNOSIS"
  1.  S IBDFLD(9)="D INPICD10^IBDFN8(.X)"
  1.  S IBDFLD(11)="D TESTICD0^IBDFN7"
  1.  S IBDIEN162=$O(^IBE(359.1,"B","SHORT NARRATIVE (60 CHAR)",""))
  1.  S IBDFLD(16.2)=IBDIEN162
  1.  S IBDIEN166=$O(^IBE(359.1,"B","ICD-10 DIAGNOSIS CODE",""))
  1.  S IBDFLD(16.6)=IBDIEN166
  1.  S IBDFLD(16.7)="ICD-10 Code"
  1.  S IBDFLD(17)="D SLCTDX10^IBDFN12(.X)"
  1.  S IBDFLD(18)=""
  1.  S IBDFLD(19)="D DX10^IBDFN14(X)"
  1.  ;create a new entry
  1.  S IBDRET=$$INSREC^IBDUTIL1(357.6,"",.IBDFLD,"")
  1.  I IBDRET<1 D MES^XPDUTL("Error: "_IBDFLD(.01)_" has NOT been added to the file #357.6 ") Q -1
  1.  D MES^XPDUTL("  "_IBDFLD(.01)_" has been added to the file #357.6 ")
  1.  S IBDIEN10=+IBDRET
  1.  ;populate DESCRIPTION
  1.  ;DESCRIPTION: Used for inputting ICD10 diagnosis codes.
  1.  S IBDARR(1,0)="Allows the user to select ICD-10 diagnosis codes from the ICD Diagnosis"
  1.  S IBDARR(2,0)="file. Allows only active codes to be selected."
  1.  S IBDRET=$$UPDWD^IBDUTIL1(357.6,IBDIEN10_",",1,"KA",.IBDARR)
  1.  I IBDRET<0 D MES^XPDUTL("Error: Description was NOT added for the"_IBDFLD(.01)_" #357.6 entry")
  1.  ;
  1.  ;get ALLOWABLE QUALIFIERS from ICD9 record
  1.  ; populate 357.613 multiple
  1.  ; 
  1.  K IBDFLD,IBDARR
  1.  D U357613(IBDIEN9,.IBDARR)
  1.  S IBDSUB=0,IBDRET=1
  1.  F  S IBDSUB=$O(IBDARR(IBDSUB)) Q:+IBDSUB=0!(IBDRET<1)  D
  1.  . S IBDFLD(.01)=$G(IBDARR(IBDSUB,.01))
  1.  . S IBDFLD(.03)=$G(IBDARR(IBDSUB,.03))
  1.  . S IBDFLD(.08)=$G(IBDARR(IBDSUB,.08))
  1.  . S IBDRET=$$INSREC^IBDUTIL1(357.613,IBDIEN10,.IBDFLD,"")
  1.  . I IBDRET<0 D MES^XPDUTL("Error: "_IBDFLD(.01)_" ALLOWABLE QUALIFIER was NOT added for the "_IBDENTRY_" #357.6 entry") Q
  1.  . D MES^XPDUTL("  "_IBDFLD(.01)_" has been added to the #357.613 multiple")
  1.  ;
  1.  ;get DATA DESCRIPTION from ICD9 record
  1.  ; populate 357.615 multiple
  1.  ; 
  1.  K IBDFLD,IBDARR
  1.  D U357615(IBDIEN9,.IBDARR)
  1.  S IBDSUB=0,IBDRET=1
  1.  F  S IBDSUB=$O(IBDARR(IBDSUB)) Q:+IBDSUB=0!(IBDRET<1)  D
  1.  . S IBDFLD(.01)=$G(IBDARR(IBDSUB,.01))
  1.  . S IBDFLD(.02)=$G(IBDARR(IBDSUB,.02))
  1.  . S IBDFLD(.03)=$G(IBDARR(IBDSUB,.03))
  1.  . S IBDFLD(.04)=$G(IBDARR(IBDSUB,.04))
  1.  . S IBDFLD(.05)=$G(IBDARR(IBDSUB,.05))
  1.  . S IBDRET=$$INSREC^IBDUTIL1(357.615,IBDIEN10,.IBDFLD,"")
  1.  . I IBDRET<0 D MES^XPDUTL("Error: "_IBDFLD(.01)_" DATA DESCRIPTION was NOT added for the "_IBDENTRY_" #357.6 entry") Q
  1.  . D MES^XPDUTL("  "_IBDFLD(.01)_" has been added to the #357.615 multiple")
  1.  ;
  1.  Q 0
  1.  ;
  1.  ;set array for #357.6 based on existing ICD-9 record
  1.  ;returns IEN for the entry if found
  1.  ; and array as
  1.  ; IBDFLD10(FLDNO)=value
  1.  ;if not then returns 0
  1.  ;Example: D ARR3576A^IBD3P63("DG SELECT ICD-9 DIAGNOSIS CODES",.IBDFLDS)
  1. ARR3576(IBDICD9,IBDFLD10) ;
  1.  ;
  1.  N IBDIEN9,IBDFLD9,IBDIEN,IBDA,IBDFLD
  1.  ;note: "B" x-ref logic for this file truncates the value to 30 chars
  1.  S IBDIEN9=$O(^IBE(357.6,"B",$E(IBDICD9,1,30),""))
  1.  I +IBDIEN9<1 Q 0
  1.  D GETS^DIQ(357.6,IBDIEN9_",","*","I","IBDFLD9")
  1.  M IBDA=IBDFLD9(357.6,IBDIEN9_",")
  1.  S IBDFLD="" F  S IBDFLD=$O(IBDA(IBDFLD)) Q:IBDFLD=""  D
  1.  . S IBDFLD10(IBDFLD)=$G(IBDA(IBDFLD,"I"))
  1.  Q IBDIEN9
  1.  ;
  1.  ;populate 357.613 multiple
  1. U357613(IBDIEN9,IBDFLD) ;
  1.  ;
  1.  N IBDSUB
  1.  S IBDSUB=0
  1.  F  S IBDSUB=$O(^IBE(357.6,IBDIEN9,13,IBDSUB)) Q:+IBDSUB=0  D
  1.  . S IBDFLD(IBDSUB,.01)=$P($G(^IBE(357.6,IBDIEN9,13,IBDSUB,0)),U,1)
  1.  . I IBDFLD(IBDSUB,.01)="" Q
  1.  . S IBDFLD(IBDSUB,.03)=$P($G(^IBE(357.6,IBDIEN9,13,IBDSUB,0)),U,3)
  1.  . S IBDFLD(IBDSUB,.08)=$P($G(^IBE(357.6,IBDIEN9,13,IBDSUB,0)),U,8)
  1.  Q
  1.  ;
  1.  ;populate 357.615 multiple
  1. U357615(IBDIEN9,IBDFLD) ;
  1.  ;
  1.  N IBDSUB,IBDDESC
  1.  S IBDSUB=0
  1.  F  S IBDSUB=$O(^IBE(357.6,IBDIEN9,15,IBDSUB)) Q:+IBDSUB=0  D
  1.  . S IBDFLD(IBDSUB,.01)=$P($G(^IBE(357.6,IBDIEN9,15,IBDSUB,0)),U,1)
  1.  . I IBDFLD(IBDSUB,.01)="" Q
  1.  . S IBDDESC=IBDFLD(IBDSUB,.01)
  1.  . S IBDFLD(IBDSUB,.02)=$S(IBDDESC="DIAGNOSIS":60,1:$P($G(^IBE(357.6,IBDIEN9,15,IBDSUB,0)),U,2))
  1.  . S IBDFLD(IBDSUB,.03)=$P($G(^IBE(357.6,IBDIEN9,15,IBDSUB,0)),U,3)
  1.  . S IBDFLD(IBDSUB,.04)=$P($G(^IBE(357.6,IBDIEN9,15,IBDSUB,0)),U,4)
  1.  . S IBDFLD(IBDSUB,.05)=$P($G(^IBE(357.6,IBDIEN9,15,IBDSUB,0)),U,5)
  1.  Q
  1.  ;
  1.  ;  Add ICD-10 Diagnosis block to Tool Kit Form
  1. ADD3571(IBDBLK) ;
  1.  N IBDFLD,IBDNAME,IBDROW,IBDTLKOR
  1.  S IBDFORM=$O(^IBE(357,"B","TOOL KIT",""))
  1.  I +IBDFORM=0 D MES^XPDUTL("Error: Tool Kit form does not exist") Q -1
  1.  S IBDNAME="ICD-10 DIAGNOSES (V1.0)"
  1.  S IBDFLD(.01)=IBDNAME
  1.  S IBDFLD(.02)=IBDFORM
  1.  S IBDFLD(.04)=0
  1.  S IBDFLD(.05)=0
  1.  S IBDFLD(.06)=132
  1.  S IBDFLD(.07)=15
  1.  S IBDFLD(.1)=1
  1.  S IBDFLD(.11)="DIAGNOSIS"
  1.  S IBDFLD(.12)="CR"
  1.  S IBDFLD(.13)="Common ICD-10 diagnoses"
  1.  S IBDTLKOR=$$TKORDER^IBDF13()
  1.  S IBDFLD(.14)=IBDTLKOR
  1.  S IBDRET=$$INSREC^IBDUTIL1(357.1,"",.IBDFLD,"")
  1.  I IBDRET<0 D MES^XPDUTL("Error: "_IBDFLD(.01)_" has NOT been added to the file #357.1") Q -1
  1.  S IBDBLK=+IBDRET
  1.  D MES^XPDUTL("  "_IBDFLD(.01)_" has been added to file #357.1")
  1.  Q 0
  1.  ; add selection list to block element.
  1. ADD3572(IBDBLK,IBDIPNAM) ;
  1.  N IBDIPIEN,IBDFLD,IBDQUIT,IBDLIST,IBDMSG
  1.  S IBDIPNAM=$G(IBDIPNAM)
  1.  S IBDQUIT=0
  1.  I IBDIPNAM="" D MES^XPDUTL("Error:  ICD-10 Interface Package not found in file #357.6.") Q -1
  1.  I IBDBLK="" D MES^XPDUTL("Error: Block not found for Tool Kit form") Q -1
  1.  S IBDIPIEN=$O(^IBE(357.6,"B",IBDIPNAM,""))
  1.  S IBDFLD(.01)="ICD-10 DIAGNOSES"
  1.  S IBDFLD(.02)=IBDBLK
  1.  S IBDFLD(.07)=4
  1.  S IBDFLD(.08)=0
  1.  S IBDFLD(.09)="SC"
  1.  S IBDFLD(.11)=IBDIPIEN
  1.  S IBDFLD(.12)=0
  1.  S IBDFLD(.14)=0
  1.  S IBDFLD(.16)=1
  1.  S IBDFLD(.17)=3
  1.  S IBDFLD(.18)=2
  1.  S IBDRET=$$INSREC^IBDUTIL1(357.2,"",.IBDFLD,"")
  1.  S IBDLIST=+IBDRET  ;set variable for IBDF routine calls
  1.  I IBDLIST<0 D MES^XPDUTL("Error: "_IBDFLD(.01)_" has NOT been added to file #357.2 ") Q -1
  1.  D MES^XPDUTL("  "_IBDFLD(.01)_" has been added to file #357.2")
  1.  D DLISTCNT^IBDFU3(IBDLIST,357.2)  ;if any, delete lists groups.
  1.  K IBDFLD
  1.  N IBDBUBL,IBDADD,IBDPRIM,IBDSECD
  1.  S IBDBUBL=$O(^IBE(357.91,"B","BUBBLE (use for scanning)",""))
  1.  S IBDADD=$O(^IBD(357.98,"B","ADD TO PROBLEM LIST",""))
  1.  S IBDPRIM=$O(^IBD(357.98,"B","PRIMARY",""))
  1.  S IBDSECD=$O(^IBD(357.98,"B","SECONDARY",""))
  1.  F IBD=1:1:5 D  Q:IBDQUIT
  1.  . K IBDFLD
  1.  . S IBDQUIT=0
  1.  . D U35722(IBD,.IBDFLD,.IBDBUBL,.IBDADD,.IBDPRIM,.IBDSECD)
  1.  . S IBDRET=$$INSREC^IBDUTIL1(357.22,IBDLIST,.IBDFLD,"")
  1.  . S IBDMSG="Error:  File #357.22 has not finished its population."
  1.  . I IBDRET<0 D MES^XPDUTL(IBDMSG) S IBDQUIT=1 Q
  1.  I IBDQUIT Q -1
  1.  D MES^XPDUTL("  ICD-10 DIAGNOSES has populated file #357.22.")
  1.  Q 0
  1.  ;
  1.  ; populate file #357.22
  1. U35722(IBD,IBDFLD,IBDBUBL,IBDADD,IBDPRIM,IBDSECD) ;
  1.  S IBDFLD(.01)=$S(IBD=1:4,IBD=2:3,IBD=3:5,IBD=4:1,1:2)
  1.  S IBDFLD(.02)=$S(IBD=1:"CODE",IBD=2:"DIAGNOSIS",IBD=3:"ADD",IBD=4:"P",1:"S")
  1.  S IBDFLD(.03)=$S(IBD=1:8,IBD=2:64,1:"")
  1.  S IBDFLD(.04)=$S(IBD=1:1,IBD=2:1,1:2)
  1.  S IBDFLD(.05)=$S(IBD=1:1,IBD=2:2,1:"")
  1.  S IBDFLD(.06)=$S(IBD=1:"",IBD=2:"",1:IBDBUBL)
  1.  S IBDFLD(.07)=$S(IBD=1:0,IBD=2:1,1:"")
  1.  S IBDFLD(.08)=$S(IBD=1:"",IBD=2:"",1:1)
  1.  S IBDFLD(.09)=$S(IBD=1:"",IBD=2:"",IBD=3:IBDADD,IBD=4:IBDPRIM,1:IBDSECD)
  1.  S IBDFLD(.1)=$S(IBD=1:"",IBD=2:"",IBD=3:0,IBD=4:1,1:0)
  1.  Q
  1.  ;
  1.  ; Copy block created in ADD3571 and ADD3572 to DEFAULTS form.
  1. COPYBLK(IBDCBLK) ;
  1.  N IBDBIEN,IBDPRINT,IBDFORM,IBDEVICE,IBDNEWBK,IBDNODE,IBDROW,IBDROW1,IBDROW2,IBDROWST,IBDROWS
  1.  D DEVICE^IBDFUA(1,.IBDEVICE)
  1.  S IBDFORM=$O(^IBE(357,"B","DEFAULTS",""))
  1.  I +IBDFORM=0 D MES^XPDUTL("Error: Defaults form does not exist") Q -2
  1.  I '$$LOCKFRM2^IBDFU7(IBDFORM) D MES^XPDUTL("Error: The form DEFAULTS is currently being edited by another user.") Q -1
  1.  D PRNTPRMS^IBDFU1C(.IBDPRINT,0,1,0,1),UNCMPL^IBDF19(.IBDFORM,0)
  1.  ; Set up IBDROW array to calculate starting row position on DEFAULTS form.
  1.  S IBDBIEN="" F  S IBDBIEN=$O(^IBE(357.1,"C",IBDFORM,IBDBIEN)) Q:IBDBIEN=""  D
  1.  .S IBDROW=$P(^IBE(357.1,IBDBIEN,0),U,4),IBDROW(IBDROW,IBDBIEN)=""
  1.  S (IBDROW1,IBDROW2,IBDBIEN)=""
  1.  S IBDROW1=$O(IBDROW(IBDROW1),-1),IBDROW2=$O(IBDROW(IBDROW1),-1)
  1.  S IBDROWS=IBDROW1-IBDROW2
  1.  S IBDBIEN=$S(IBDROWS>20:$O(IBDROW(IBDROW2,"")),1:$O(IBDROW(IBDROW1,"")))
  1.  S IBDNODE=^IBE(357.1,IBDBIEN,0)
  1.  S IBDROWST=$P(IBDNODE,U,4)
  1.  S IBDROW=IBDROWST+$P(IBDNODE,U,7)+2
  1.  S IBDNEWBK=$$COPYBLK^IBDFU2(IBDCBLK,IBDFORM,357.1,357.1,IBDROW,1,0,"",1)
  1.  I IBDNEWBK<0 D MES^XPDUTL("Error: ICD-10 DIAGNOSES (V1.0) block was not copied to DEFAULTS form") Q -1
  1.  D MES^XPDUTL("  ICD-10 DIAGNOSES (V1.0) block was copied to DEFAULTS form")
  1.  Q 0
  1.  ;
  1.  ;IBD3P63