DG53850B ;ALB/JRC - ICD-10 POST-INIT ;3/12/11 7:21am
;;5.3;Registration;**850**;Aug 13, 1993;Build 171
;
Q
;
EN ; -- Post init entry
N DGPATCH,DGRETV,DGCATAR,DG4589ST,DG2717ST
S DGRETV=0
S DGPATCH=$$PATCH^XPDUTL("DG*5.3*850")
I DGPATCH D MES^XPDUTL("Patch DG*5.3*850 previously installed - File 27.17 and File #45.89 updates skipped.")
I 'DGPATCH D
. S DG2717ST=100 ;IEN to start adding ICD-10 entries in #27.17
. S DG4589ST=5000 ;IEN to start adding ICD-10 entries in #45.89
. S DGRETV=$$CHKPREP(.DGCATAR,DG2717ST,DG4589ST)
. I DGRETV<0 Q
. D BMES^XPDUTL("File #27.17:")
. D UPD^DG53850D(DG2717ST)
. D BMES^XPDUTL("File #45.89:")
. D UPD4589(DG4589ST)
. D REIN4589
. D ADD4589(.DGCATAR,DG4589ST)
I DGRETV<0 D MES^XPDUTL("Installation aborted. Fix the issues and start again.") Q
;
D REC ;,ICD
Q
;
REC ; -- re-compile all compiled input templates.
N X,Y,DA,DIK,DMAX,DGERR,DGDUZSV,DGINTP,DNM
I $G(DUZ)="" W !,"Your DUZ is not defined. It must be defined to run this routine." Q
S DGDUZSV=DUZ(0),DUZ(0)="@"
;
D BMES^XPDUTL("Compiling Input Templates....")
;
F DGINTP="DG101","DG401","DG501","DG501F","DG701" S Y=$O(^DIE("B",DGINTP,0)) S DGERR=0 D I DGERR D BMES^XPDUTL("** "_DGINTP_" input template could not be updated")
.I 'Y S DGERR=1 Q
.S X=$P($G(^DIE(Y,"ROU")),U,2) I X="" S DGERR=1 Q
.S DMAX=$$ROUSIZE^DILF D EN^DIEZ
;
S DUZ(0)=DGDUZSV
Q
;
;re-index #4589
REIN4589 ;
D BMES^XPDUTL("Re-indexing existing ICD-9 entries for new indexes ....")
N DIK
S DIK="^DIC(45.89,"
S DIK(1)=".02^ACODE"
D ENALL^DIK
Q
;adding coding system values to existing ICD-9 entries
UPD4589(DG9IEN) ;
N DGIEN,DGX
D BMES^XPDUTL("Populating the new field #.05 for pre-existing ICD-9 entries")
S DGIEN=0
F S DGIEN=$O(^DIC(45.89,DGIEN)) Q:+DGIEN=0!(DGIEN'<DG9IEN) D
. S DGX=$P($G(^DIC(45.89,DGIEN,0)),U,2)
. S DGCSYS=$$CSI^ICDEX($S(DGX["ICD9":80,1:80.1),+DGX)
. I 'DGCSYS Q
. I +$$FILLFLDS(45.89,.05,DGIEN,DGCSYS)=0 D MES^XPDUTL("Code "_$$CODEC^ICDEX($S(DGX["ICD9":80,1:80.1),+DGX)_" wasn't updated")
Q
;
;check values and prepare arrays
CHKPREP(DGCATAR,DG2717ST,DG4589ST) ;
N DGCATS,DGIEN,DGIENMAX,DGQUIT
I '$O(^DIC(45.89,0)) D BMES^XPDUTL("File #45.89 doesn't have any entries. Please restore the file and then install the patch.") Q -2
I '$O(^DGEN(27.17,0)) D BMES^XPDUTL("File #27.17 doesn't have any entries. Please restore the file and then install the patch.") Q -3
S DGQUIT=0
S DGIENMAX=DG2717ST+200 D I DGQUIT=1 D BMES^XPDUTL("File #27.17 contains entries with IENs in the range "_DG2717ST_" - "_DGIENMAX_". Please restore the standard data and then install the patch.") Q -5
. F DGIEN=DG2717ST:1:DGIENMAX I $D(^DIC(27.17,DGIEN)) S DGQUIT=1 Q
S DGQUIT=0
S DGIENMAX=DG4589ST+1500 D I DGQUIT=1 D BMES^XPDUTL("File #45.89 contains entries with IENs in the range "_DG4589ST_" - "_DGIENMAX_". Please restore the original data and then install the patch.") Q -6
. F DGIEN=DG4589ST:1:DGIENMAX I $D(^DIC(27.17,DGIEN)) S DGQUIT=1 Q
S DGQUIT=0
F DGCATS="SUBSTANCE ABUSE","SUICIDE INDICATOR","KIDNEY TRANSPLANT STATUS","DIALYSIS TYPE" D Q:DGQUIT=1
. S DGCATAR(DGCATS)=$O(^DIC(45.88,"B",DGCATS,0))
. I +DGCATAR(DGCATS)=0 D BMES^XPDUTL(DGCATS_" wasn't found in the file 45.88. Please correct the file and then install the patch.") S DGQUIT=1
Q:DGQUIT=1 -1
Q 1
;
;adding ICD-10 entries to #45.89
;DGCATAR - array with categories (populated by CHKPREP)
;DG10IEN - IEN to start with
ADD4589(DGCATAR,DG10IEN) ;
N DGSTIEN
D BMES^XPDUTL("Adding diagnoses to the file #45.89")
S DGSTIEN=$$DIAG4589(DG10IEN,.DGCATAR)
D BMES^XPDUTL("Adding Procedure to the file #45.89")
S DGSTIEN=$$PROC4589(DGSTIEN,.DGCATAR)
W DGSTIEN
Q
;
DIAG4589(DGIEN,DGCATAR) ;
N DGY,DGX,DGY2,DGX2,DGCNT1,DGCNT2,DGVAL,DGCAT
S (DGCNT1,DGCNT2)=0
S DGVAL(.05)=30
;SUBSTANCE ABUSE diagnoses
D BMES^XPDUTL(" Adding SUBSTANCE ABUSE entries...")
S DGVAL(.01)=DGCATAR("SUBSTANCE ABUSE")
F DGY=1:1 S DGX=$P($T(DSUBST+DGY^DG53850C),";",3) Q:DGX="" D
. S DGCNT1=DGCNT1+1
. F DGY2=1:1 S DGX2=$P(DGX,",",DGY2) Q:DGX2="" D
.. S DGVAL(.02)=(+$$CODEN^ICDEX(DGX2,80))_";ICD9("
.. I $G(DGVAL(.02))=-1 D BMES^XPDUTL("Code "_DGX2_" was not found in the file #80") Q
.. I $$INSREC(45.89,"",.DGVAL,DGIEN,,,,1)<0 D BMES^XPDUTL("Code "_DGX2_" was not added to the file #45.89")
.. S DGIEN=DGIEN+1
.. S DGCNT2=DGCNT2+1
;D BMES^XPDUTL(DGCNT2_" codes have been added.")
;SUICIDE INDICATOR diagnoses
D BMES^XPDUTL(" Adding SUICIDE INDICATOR entries...")
S DGVAL(.01)=DGCATAR("SUICIDE INDICATOR")
F DGY=1:1 S DGX=$P($T(DSUIC+DGY^DG53850C),";",3) Q:DGX="" D
. S DGCNT1=DGCNT1+1
. F DGY2=1:1 S DGX2=$P(DGX,",",DGY2) Q:DGX2="" D
.. S DGVAL(.02)=(+$$CODEN^ICDEX(DGX2,80))_";ICD9("
.. I $G(DGVAL(.02))=-1 D BMES^XPDUTL("Code "_DGX2_" was not found in the file #80") Q
.. I $$INSREC(45.89,"",.DGVAL,DGIEN,,,,1)<0 D BMES^XPDUTL("Code "_DGX2_" was not added to the file #45.89")
.. S DGIEN=DGIEN+1
.. S DGCNT2=DGCNT2+1
;D BMES^XPDUTL(DGCNT2_" codes have been added.")
;KIDNEY TRANSPLANT STATUS diagnoses
D BMES^XPDUTL(" Adding KIDNEY TRANSPLANT entries...")
S DGVAL(.01)=DGCATAR("KIDNEY TRANSPLANT STATUS")
F DGY=1:1 S DGX=$P($T(DKIDNEY+DGY^DG53850C),";",3) Q:DGX="" D
. S DGCNT1=DGCNT1+1
. F DGY2=1:1 S DGX2=$P(DGX,",",DGY2) Q:DGX2="" D
.. S DGVAL(.02)=(+$$CODEN^ICDEX(DGX2,80))_";ICD9("
.. I $G(DGVAL(.02))=-1 D BMES^XPDUTL("Code "_DGX2_" was not found in the file #80") Q
.. I $$INSREC(45.89,"",.DGVAL,DGIEN,,,,1)<0 D BMES^XPDUTL("Code "_DGX2_" was not added to the file #45.89")
.. S DGIEN=DGIEN+1
.. S DGCNT2=DGCNT2+1
D BMES^XPDUTL(" "_DGCNT2_" codes have been added.")
Q DGIEN
;
PROC4589(DGIEN,DGCATAR) ;
N DGY,DGX,DGY2,DGX2,DGCNT1,DGCNT2,DGVAL
S (DGCNT1,DGCNT2)=0
S DGVAL(.05)=31
D BMES^XPDUTL(" Adding DIALYSIS TYPE entries...")
S DGVAL(.01)=DGCATAR("DIALYSIS TYPE")
F DGY=1:1 S DGX=$P($T(PDIAL+DGY^DG53850C),";",3) Q:DGX="" D
. W "."
. S DGCNT1=DGCNT1+1
. F DGY2=1:1 S DGX2=$P(DGX,",",DGY2) Q:DGX2="" D
.. S DGVAL(.02)=(+$$CODEN^ICDEX(DGX2,80.1))_";ICD0("
.. I $G(DGVAL(.02))=-1 D BMES^XPDUTL("Code "_DGX2_" was not found in the file #80.1") Q
.. I $$INSREC(45.89,"",.DGVAL,DGIEN,,,,1)<0 D BMES^XPDUTL("Code "_DGX2_" was not added to the file #45.89")
.. S DGIEN=DGIEN+1
.. S DGCNT2=DGCNT2+1
D BMES^XPDUTL(" "_DGCNT2_" codes have been added.")
Q DGIEN
;
;/**
;Creates a new entry (or node for multiple with .01 field)
;
;DGFILE - file/subfile number
;DGIEN - ien of the parent file entry in which the new subfile entry will be inserted
;DGZFDA - array with values for the fields
; format for DGZFDA:
; DGZFDA(.01)=value for #.01 field
; DGZFDA(3)=value for #3 field
;DGRECNO -(optional) specify IEN if you want specific value
; Note: "" then the system will assign the entry number itself.
;DGFLGS - FLAGS parameter for UPDATE^DIE
;DGLCKGL - fully specified global reference to lock
;DGLCKTM - time out for LOCK, if LOCKTIME=0 then the function will not lock the file
;DGNEWRE - optional, flag = if 1 then allow to create a new top level record
;
;output :
; positive number - record # created
; <=0 - failure
;
;Example:
;"6^564419;ICD0(^^^31" to create an entry with IEN=5000
;S ZZ(.01)=6,ZZ(.02)="564419;ICD0(",ZZ(.05)=31 W $$INSREC^DG53850C(45.89,"",.ZZ,5000,,,,1)
INSREC(DGFILE,DGIEN,DGZFDA,DGRECNO,DGFLGS,DGLCKGL,DGLCKTM,DGNEWRE) ;*/
I ('$G(DGFILE)) Q "0^Invalid parameter"
I +$G(DGNEWRE)=0 I $G(DGRECNO)>0,'$G(DGIEN) Q "0^Invalid parameter"
N DGSSI,DGIENS,DGERR,DGFDA
N DGLOCK S DGLOCK=0
I '$G(DGRECNO) N DGRECNO S DGRECNO=$G(DGRECNO)
I DGIEN'="" S DGIENS="+1,"_DGIEN_"," I $L(DGRECNO)>0 S DGSSI(1)=+DGRECNO
I DGIEN="" S DGIENS="+1," I $L(DGRECNO)>0 S DGSSI(1)=+DGRECNO
M DGFDA(DGFILE,DGIENS)=DGZFDA
I $L($G(DGLCKGL)) L +@DGLCKGL:(+$G(DGLCKTM)) S DGLOCK=$T I 'DGLOCK Q -2 ;lock failure
D UPDATE^DIE($G(DGFLGS),"DGFDA","DGSSI","DGERR")
I DGLOCK L -@DGLCKGL
I $D(DGERR) Q -1 ;D BMES^XPDUTL($G(DGERR("DIERR",1,"TEXT",1),"Update Error")) Q -1
Q +$G(DGSSI(1))
;
;populate fields
;Input:
;DGFILE file number
;DGFLD field number
;DGIENS ien string
;DGNEWVAL new value to file (internal format)
;Output:
;0^ DGNEWVAL^error if failure
;1^ DGNEWVAL if success
FILLFLDS(DGFILE,DGFLD,DGIENS,DGNEWVAL) ;
I '$G(DGFILE) Q "0^Invalid parameter"
I '$G(DGFLD) Q "0^Invalid parameter"
I '$G(DGIENS) Q "0^Invalid parameter"
I $G(DGNEWVAL)="" Q "0^Null"
N DGIENSTR,FDA,ERRARR
S DGIENSTR=DGIENS_","
S FDA(DGFILE,DGIENSTR,DGFLD)=DGNEWVAL
D FILE^DIE("","FDA","ERRARR")
I $D(ERRARR) Q "0^"_DGNEWVAL_"^"_ERRARR("DIERR",1,"TEXT",1)
Q "1^"_DGNEWVAL
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDG53850B 8770 printed Dec 13, 2024@02:39:04 Page 2
DG53850B ;ALB/JRC - ICD-10 POST-INIT ;3/12/11 7:21am
+1 ;;5.3;Registration;**850**;Aug 13, 1993;Build 171
+2 ;
+3 QUIT
+4 ;
EN ; -- Post init entry
+1 NEW DGPATCH,DGRETV,DGCATAR,DG4589ST,DG2717ST
+2 SET DGRETV=0
+3 SET DGPATCH=$$PATCH^XPDUTL("DG*5.3*850")
+4 IF DGPATCH
DO MES^XPDUTL("Patch DG*5.3*850 previously installed - File 27.17 and File #45.89 updates skipped.")
+5 IF 'DGPATCH
Begin DoDot:1
+6 ;IEN to start adding ICD-10 entries in #27.17
SET DG2717ST=100
+7 ;IEN to start adding ICD-10 entries in #45.89
SET DG4589ST=5000
+8 SET DGRETV=$$CHKPREP(.DGCATAR,DG2717ST,DG4589ST)
+9 IF DGRETV<0
QUIT
+10 DO BMES^XPDUTL("File #27.17:")
+11 DO UPD^DG53850D(DG2717ST)
+12 DO BMES^XPDUTL("File #45.89:")
+13 DO UPD4589(DG4589ST)
+14 DO REIN4589
+15 DO ADD4589(.DGCATAR,DG4589ST)
End DoDot:1
+16 IF DGRETV<0
DO MES^XPDUTL("Installation aborted. Fix the issues and start again.")
QUIT
+17 ;
+18 ;,ICD
DO REC
+19 QUIT
+20 ;
REC ; -- re-compile all compiled input templates.
+1 NEW X,Y,DA,DIK,DMAX,DGERR,DGDUZSV,DGINTP,DNM
+2 IF $GET(DUZ)=""
WRITE !,"Your DUZ is not defined. It must be defined to run this routine."
QUIT
+3 SET DGDUZSV=DUZ(0)
SET DUZ(0)="@"
+4 ;
+5 DO BMES^XPDUTL("Compiling Input Templates....")
+6 ;
+7 FOR DGINTP="DG101","DG401","DG501","DG501F","DG701"
SET Y=$ORDER(^DIE("B",DGINTP,0))
SET DGERR=0
Begin DoDot:1
+8 IF 'Y
SET DGERR=1
QUIT
+9 SET X=$PIECE($GET(^DIE(Y,"ROU")),U,2)
IF X=""
SET DGERR=1
QUIT
+10 SET DMAX=$$ROUSIZE^DILF
DO EN^DIEZ
End DoDot:1
IF DGERR
DO BMES^XPDUTL("** "_DGINTP_" input template could not be updated")
+11 ;
+12 SET DUZ(0)=DGDUZSV
+13 QUIT
+14 ;
+15 ;re-index #4589
REIN4589 ;
+1 DO BMES^XPDUTL("Re-indexing existing ICD-9 entries for new indexes ....")
+2 NEW DIK
+3 SET DIK="^DIC(45.89,"
+4 SET DIK(1)=".02^ACODE"
+5 DO ENALL^DIK
+6 QUIT
+7 ;adding coding system values to existing ICD-9 entries
UPD4589(DG9IEN) ;
+1 NEW DGIEN,DGX
+2 DO BMES^XPDUTL("Populating the new field #.05 for pre-existing ICD-9 entries")
+3 SET DGIEN=0
+4 FOR
SET DGIEN=$ORDER(^DIC(45.89,DGIEN))
if +DGIEN=0!(DGIEN'<DG9IEN)
QUIT
Begin DoDot:1
+5 SET DGX=$PIECE($GET(^DIC(45.89,DGIEN,0)),U,2)
+6 SET DGCSYS=$$CSI^ICDEX($SELECT(DGX["ICD9":80,1:80.1),+DGX)
+7 IF 'DGCSYS
QUIT
+8 IF +$$FILLFLDS(45.89,.05,DGIEN,DGCSYS)=0
DO MES^XPDUTL("Code "_$$CODEC^ICDEX($SELECT(DGX["ICD9":80,1:80.1),+DGX)_" wasn't updated")
End DoDot:1
+9 QUIT
+10 ;
+11 ;check values and prepare arrays
CHKPREP(DGCATAR,DG2717ST,DG4589ST) ;
+1 NEW DGCATS,DGIEN,DGIENMAX,DGQUIT
+2 IF '$ORDER(^DIC(45.89,0))
DO BMES^XPDUTL("File #45.89 doesn't have any entries. Please restore the file and then install the patch.")
QUIT -2
+3 IF '$ORDER(^DGEN(27.17,0))
DO BMES^XPDUTL("File #27.17 doesn't have any entries. Please restore the file and then install the patch.")
QUIT -3
+4 SET DGQUIT=0
+5 SET DGIENMAX=DG2717ST+200
Begin DoDot:1
+6 FOR DGIEN=DG2717ST:1:DGIENMAX
IF $DATA(^DIC(27.17,DGIEN))
SET DGQUIT=1
QUIT
End DoDot:1
IF DGQUIT=1
DO BMES^XPDUTL("File #27.17 contains entries with IENs in the range "_DG2717ST_" - "_DGIENMAX_". Please restore the standard data and then install the patch.")
QUIT -5
+7 SET DGQUIT=0
+8 SET DGIENMAX=DG4589ST+1500
Begin DoDot:1
+9 FOR DGIEN=DG4589ST:1:DGIENMAX
IF $DATA(^DIC(27.17,DGIEN))
SET DGQUIT=1
QUIT
End DoDot:1
IF DGQUIT=1
DO BMES^XPDUTL("File #45.89 contains entries with IENs in the range "_DG4589ST_" - "_DGIENMAX_". Please restore the original data and then install the patch.")
QUIT -6
+10 SET DGQUIT=0
+11 FOR DGCATS="SUBSTANCE ABUSE","SUICIDE INDICATOR","KIDNEY TRANSPLANT STATUS","DIALYSIS TYPE"
Begin DoDot:1
+12 SET DGCATAR(DGCATS)=$ORDER(^DIC(45.88,"B",DGCATS,0))
+13 IF +DGCATAR(DGCATS)=0
DO BMES^XPDUTL(DGCATS_" wasn't found in the file 45.88. Please correct the file and then install the patch.")
SET DGQUIT=1
End DoDot:1
if DGQUIT=1
QUIT
+14 if DGQUIT=1
QUIT -1
+15 QUIT 1
+16 ;
+17 ;adding ICD-10 entries to #45.89
+18 ;DGCATAR - array with categories (populated by CHKPREP)
+19 ;DG10IEN - IEN to start with
ADD4589(DGCATAR,DG10IEN) ;
+1 NEW DGSTIEN
+2 DO BMES^XPDUTL("Adding diagnoses to the file #45.89")
+3 SET DGSTIEN=$$DIAG4589(DG10IEN,.DGCATAR)
+4 DO BMES^XPDUTL("Adding Procedure to the file #45.89")
+5 SET DGSTIEN=$$PROC4589(DGSTIEN,.DGCATAR)
+6 WRITE DGSTIEN
+7 QUIT
+8 ;
DIAG4589(DGIEN,DGCATAR) ;
+1 NEW DGY,DGX,DGY2,DGX2,DGCNT1,DGCNT2,DGVAL,DGCAT
+2 SET (DGCNT1,DGCNT2)=0
+3 SET DGVAL(.05)=30
+4 ;SUBSTANCE ABUSE diagnoses
+5 DO BMES^XPDUTL(" Adding SUBSTANCE ABUSE entries...")
+6 SET DGVAL(.01)=DGCATAR("SUBSTANCE ABUSE")
+7 FOR DGY=1:1
SET DGX=$PIECE($TEXT(DSUBST+DGY^DG53850C),";",3)
if DGX=""
QUIT
Begin DoDot:1
+8 SET DGCNT1=DGCNT1+1
+9 FOR DGY2=1:1
SET DGX2=$PIECE(DGX,",",DGY2)
if DGX2=""
QUIT
Begin DoDot:2
+10 SET DGVAL(.02)=(+$$CODEN^ICDEX(DGX2,80))_";ICD9("
+11 IF $GET(DGVAL(.02))=-1
DO BMES^XPDUTL("Code "_DGX2_" was not found in the file #80")
QUIT
+12 IF $$INSREC(45.89,"",.DGVAL,DGIEN,,,,1)<0
DO BMES^XPDUTL("Code "_DGX2_" was not added to the file #45.89")
+13 SET DGIEN=DGIEN+1
+14 SET DGCNT2=DGCNT2+1
End DoDot:2
End DoDot:1
+15 ;D BMES^XPDUTL(DGCNT2_" codes have been added.")
+16 ;SUICIDE INDICATOR diagnoses
+17 DO BMES^XPDUTL(" Adding SUICIDE INDICATOR entries...")
+18 SET DGVAL(.01)=DGCATAR("SUICIDE INDICATOR")
+19 FOR DGY=1:1
SET DGX=$PIECE($TEXT(DSUIC+DGY^DG53850C),";",3)
if DGX=""
QUIT
Begin DoDot:1
+20 SET DGCNT1=DGCNT1+1
+21 FOR DGY2=1:1
SET DGX2=$PIECE(DGX,",",DGY2)
if DGX2=""
QUIT
Begin DoDot:2
+22 SET DGVAL(.02)=(+$$CODEN^ICDEX(DGX2,80))_";ICD9("
+23 IF $GET(DGVAL(.02))=-1
DO BMES^XPDUTL("Code "_DGX2_" was not found in the file #80")
QUIT
+24 IF $$INSREC(45.89,"",.DGVAL,DGIEN,,,,1)<0
DO BMES^XPDUTL("Code "_DGX2_" was not added to the file #45.89")
+25 SET DGIEN=DGIEN+1
+26 SET DGCNT2=DGCNT2+1
End DoDot:2
End DoDot:1
+27 ;D BMES^XPDUTL(DGCNT2_" codes have been added.")
+28 ;KIDNEY TRANSPLANT STATUS diagnoses
+29 DO BMES^XPDUTL(" Adding KIDNEY TRANSPLANT entries...")
+30 SET DGVAL(.01)=DGCATAR("KIDNEY TRANSPLANT STATUS")
+31 FOR DGY=1:1
SET DGX=$PIECE($TEXT(DKIDNEY+DGY^DG53850C),";",3)
if DGX=""
QUIT
Begin DoDot:1
+32 SET DGCNT1=DGCNT1+1
+33 FOR DGY2=1:1
SET DGX2=$PIECE(DGX,",",DGY2)
if DGX2=""
QUIT
Begin DoDot:2
+34 SET DGVAL(.02)=(+$$CODEN^ICDEX(DGX2,80))_";ICD9("
+35 IF $GET(DGVAL(.02))=-1
DO BMES^XPDUTL("Code "_DGX2_" was not found in the file #80")
QUIT
+36 IF $$INSREC(45.89,"",.DGVAL,DGIEN,,,,1)<0
DO BMES^XPDUTL("Code "_DGX2_" was not added to the file #45.89")
+37 SET DGIEN=DGIEN+1
+38 SET DGCNT2=DGCNT2+1
End DoDot:2
End DoDot:1
+39 DO BMES^XPDUTL(" "_DGCNT2_" codes have been added.")
+40 QUIT DGIEN
+41 ;
PROC4589(DGIEN,DGCATAR) ;
+1 NEW DGY,DGX,DGY2,DGX2,DGCNT1,DGCNT2,DGVAL
+2 SET (DGCNT1,DGCNT2)=0
+3 SET DGVAL(.05)=31
+4 DO BMES^XPDUTL(" Adding DIALYSIS TYPE entries...")
+5 SET DGVAL(.01)=DGCATAR("DIALYSIS TYPE")
+6 FOR DGY=1:1
SET DGX=$PIECE($TEXT(PDIAL+DGY^DG53850C),";",3)
if DGX=""
QUIT
Begin DoDot:1
+7 WRITE "."
+8 SET DGCNT1=DGCNT1+1
+9 FOR DGY2=1:1
SET DGX2=$PIECE(DGX,",",DGY2)
if DGX2=""
QUIT
Begin DoDot:2
+10 SET DGVAL(.02)=(+$$CODEN^ICDEX(DGX2,80.1))_";ICD0("
+11 IF $GET(DGVAL(.02))=-1
DO BMES^XPDUTL("Code "_DGX2_" was not found in the file #80.1")
QUIT
+12 IF $$INSREC(45.89,"",.DGVAL,DGIEN,,,,1)<0
DO BMES^XPDUTL("Code "_DGX2_" was not added to the file #45.89")
+13 SET DGIEN=DGIEN+1
+14 SET DGCNT2=DGCNT2+1
End DoDot:2
End DoDot:1
+15 DO BMES^XPDUTL(" "_DGCNT2_" codes have been added.")
+16 QUIT DGIEN
+17 ;
+18 ;/**
+19 ;Creates a new entry (or node for multiple with .01 field)
+20 ;
+21 ;DGFILE - file/subfile number
+22 ;DGIEN - ien of the parent file entry in which the new subfile entry will be inserted
+23 ;DGZFDA - array with values for the fields
+24 ; format for DGZFDA:
+25 ; DGZFDA(.01)=value for #.01 field
+26 ; DGZFDA(3)=value for #3 field
+27 ;DGRECNO -(optional) specify IEN if you want specific value
+28 ; Note: "" then the system will assign the entry number itself.
+29 ;DGFLGS - FLAGS parameter for UPDATE^DIE
+30 ;DGLCKGL - fully specified global reference to lock
+31 ;DGLCKTM - time out for LOCK, if LOCKTIME=0 then the function will not lock the file
+32 ;DGNEWRE - optional, flag = if 1 then allow to create a new top level record
+33 ;
+34 ;output :
+35 ; positive number - record # created
+36 ; <=0 - failure
+37 ;
+38 ;Example:
+39 ;"6^564419;ICD0(^^^31" to create an entry with IEN=5000
+40 ;S ZZ(.01)=6,ZZ(.02)="564419;ICD0(",ZZ(.05)=31 W $$INSREC^DG53850C(45.89,"",.ZZ,5000,,,,1)
INSREC(DGFILE,DGIEN,DGZFDA,DGRECNO,DGFLGS,DGLCKGL,DGLCKTM,DGNEWRE) ;*/
+1 IF ('$GET(DGFILE))
QUIT "0^Invalid parameter"
+2 IF +$GET(DGNEWRE)=0
IF $GET(DGRECNO)>0
IF '$GET(DGIEN)
QUIT "0^Invalid parameter"
+3 NEW DGSSI,DGIENS,DGERR,DGFDA
+4 NEW DGLOCK
SET DGLOCK=0
+5 IF '$GET(DGRECNO)
NEW DGRECNO
SET DGRECNO=$GET(DGRECNO)
+6 IF DGIEN'=""
SET DGIENS="+1,"_DGIEN_","
IF $LENGTH(DGRECNO)>0
SET DGSSI(1)=+DGRECNO
+7 IF DGIEN=""
SET DGIENS="+1,"
IF $LENGTH(DGRECNO)>0
SET DGSSI(1)=+DGRECNO
+8 MERGE DGFDA(DGFILE,DGIENS)=DGZFDA
+9 ;lock failure
IF $LENGTH($GET(DGLCKGL))
LOCK +@DGLCKGL:(+$GET(DGLCKTM))
SET DGLOCK=$TEST
IF 'DGLOCK
QUIT -2
+10 DO UPDATE^DIE($GET(DGFLGS),"DGFDA","DGSSI","DGERR")
+11 IF DGLOCK
LOCK -@DGLCKGL
+12 ;D BMES^XPDUTL($G(DGERR("DIERR",1,"TEXT",1),"Update Error")) Q -1
IF $DATA(DGERR)
QUIT -1
+13 QUIT +$GET(DGSSI(1))
+14 ;
+15 ;populate fields
+16 ;Input:
+17 ;DGFILE file number
+18 ;DGFLD field number
+19 ;DGIENS ien string
+20 ;DGNEWVAL new value to file (internal format)
+21 ;Output:
+22 ;0^ DGNEWVAL^error if failure
+23 ;1^ DGNEWVAL if success
FILLFLDS(DGFILE,DGFLD,DGIENS,DGNEWVAL) ;
+1 IF '$GET(DGFILE)
QUIT "0^Invalid parameter"
+2 IF '$GET(DGFLD)
QUIT "0^Invalid parameter"
+3 IF '$GET(DGIENS)
QUIT "0^Invalid parameter"
+4 IF $GET(DGNEWVAL)=""
QUIT "0^Null"
+5 NEW DGIENSTR,FDA,ERRARR
+6 SET DGIENSTR=DGIENS_","
+7 SET FDA(DGFILE,DGIENSTR,DGFLD)=DGNEWVAL
+8 DO FILE^DIE("","FDA","ERRARR")
+9 IF $DATA(ERRARR)
QUIT "0^"_DGNEWVAL_"^"_ERRARR("DIERR",1,"TEXT",1)
+10 QUIT "1^"_DGNEWVAL
+11 ;
