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