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

DG53850B.m

Go to the documentation of this file.
  1. DG53850B ;ALB/JRC - ICD-10 POST-INIT ;3/12/11 7:21am
  1. ;;5.3;Registration;**850**;Aug 13, 1993;Build 171
  1. ;
  1. Q
  1. ;
  1. EN ; -- Post init entry
  1. N DGPATCH,DGRETV,DGCATAR,DG4589ST,DG2717ST
  1. S DGRETV=0
  1. S DGPATCH=$$PATCH^XPDUTL("DG*5.3*850")
  1. I DGPATCH D MES^XPDUTL("Patch DG*5.3*850 previously installed - File 27.17 and File #45.89 updates skipped.")
  1. I 'DGPATCH D
  1. . S DG2717ST=100 ;IEN to start adding ICD-10 entries in #27.17
  1. . S DG4589ST=5000 ;IEN to start adding ICD-10 entries in #45.89
  1. . S DGRETV=$$CHKPREP(.DGCATAR,DG2717ST,DG4589ST)
  1. . I DGRETV<0 Q
  1. . D BMES^XPDUTL("File #27.17:")
  1. . D UPD^DG53850D(DG2717ST)
  1. . D BMES^XPDUTL("File #45.89:")
  1. . D UPD4589(DG4589ST)
  1. . D REIN4589
  1. . D ADD4589(.DGCATAR,DG4589ST)
  1. I DGRETV<0 D MES^XPDUTL("Installation aborted. Fix the issues and start again.") Q
  1. ;
  1. D REC ;,ICD
  1. Q
  1. ;
  1. REC ; -- re-compile all compiled input templates.
  1. N X,Y,DA,DIK,DMAX,DGERR,DGDUZSV,DGINTP,DNM
  1. I $G(DUZ)="" W !,"Your DUZ is not defined. It must be defined to run this routine." Q
  1. S DGDUZSV=DUZ(0),DUZ(0)="@"
  1. ;
  1. D BMES^XPDUTL("Compiling Input Templates....")
  1. ;
  1. 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")
  1. .I 'Y S DGERR=1 Q
  1. .S X=$P($G(^DIE(Y,"ROU")),U,2) I X="" S DGERR=1 Q
  1. .S DMAX=$$ROUSIZE^DILF D EN^DIEZ
  1. ;
  1. S DUZ(0)=DGDUZSV
  1. Q
  1. ;
  1. ;re-index #4589
  1. REIN4589 ;
  1. D BMES^XPDUTL("Re-indexing existing ICD-9 entries for new indexes ....")
  1. N DIK
  1. S DIK="^DIC(45.89,"
  1. S DIK(1)=".02^ACODE"
  1. D ENALL^DIK
  1. Q
  1. ;adding coding system values to existing ICD-9 entries
  1. UPD4589(DG9IEN) ;
  1. N DGIEN,DGX
  1. D BMES^XPDUTL("Populating the new field #.05 for pre-existing ICD-9 entries")
  1. S DGIEN=0
  1. F S DGIEN=$O(^DIC(45.89,DGIEN)) Q:+DGIEN=0!(DGIEN'<DG9IEN) D
  1. . S DGX=$P($G(^DIC(45.89,DGIEN,0)),U,2)
  1. . S DGCSYS=$$CSI^ICDEX($S(DGX["ICD9":80,1:80.1),+DGX)
  1. . I 'DGCSYS Q
  1. . 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")
  1. Q
  1. ;
  1. ;check values and prepare arrays
  1. CHKPREP(DGCATAR,DG2717ST,DG4589ST) ;
  1. N DGCATS,DGIEN,DGIENMAX,DGQUIT
  1. 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
  1. 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
  1. S DGQUIT=0
  1. 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
  1. . F DGIEN=DG2717ST:1:DGIENMAX I $D(^DIC(27.17,DGIEN)) S DGQUIT=1 Q
  1. S DGQUIT=0
  1. 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
  1. . F DGIEN=DG4589ST:1:DGIENMAX I $D(^DIC(27.17,DGIEN)) S DGQUIT=1 Q
  1. S DGQUIT=0
  1. F DGCATS="SUBSTANCE ABUSE","SUICIDE INDICATOR","KIDNEY TRANSPLANT STATUS","DIALYSIS TYPE" D Q:DGQUIT=1
  1. . S DGCATAR(DGCATS)=$O(^DIC(45.88,"B",DGCATS,0))
  1. . 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
  1. Q:DGQUIT=1 -1
  1. Q 1
  1. ;
  1. ;adding ICD-10 entries to #45.89
  1. ;DGCATAR - array with categories (populated by CHKPREP)
  1. ;DG10IEN - IEN to start with
  1. ADD4589(DGCATAR,DG10IEN) ;
  1. N DGSTIEN
  1. D BMES^XPDUTL("Adding diagnoses to the file #45.89")
  1. S DGSTIEN=$$DIAG4589(DG10IEN,.DGCATAR)
  1. D BMES^XPDUTL("Adding Procedure to the file #45.89")
  1. S DGSTIEN=$$PROC4589(DGSTIEN,.DGCATAR)
  1. W DGSTIEN
  1. Q
  1. ;
  1. DIAG4589(DGIEN,DGCATAR) ;
  1. N DGY,DGX,DGY2,DGX2,DGCNT1,DGCNT2,DGVAL,DGCAT
  1. S (DGCNT1,DGCNT2)=0
  1. S DGVAL(.05)=30
  1. ;SUBSTANCE ABUSE diagnoses
  1. D BMES^XPDUTL(" Adding SUBSTANCE ABUSE entries...")
  1. S DGVAL(.01)=DGCATAR("SUBSTANCE ABUSE")
  1. F DGY=1:1 S DGX=$P($T(DSUBST+DGY^DG53850C),";",3) Q:DGX="" D
  1. . S DGCNT1=DGCNT1+1
  1. . F DGY2=1:1 S DGX2=$P(DGX,",",DGY2) Q:DGX2="" D
  1. .. S DGVAL(.02)=(+$$CODEN^ICDEX(DGX2,80))_";ICD9("
  1. .. I $G(DGVAL(.02))=-1 D BMES^XPDUTL("Code "_DGX2_" was not found in the file #80") Q
  1. .. I $$INSREC(45.89,"",.DGVAL,DGIEN,,,,1)<0 D BMES^XPDUTL("Code "_DGX2_" was not added to the file #45.89")
  1. .. S DGIEN=DGIEN+1
  1. .. S DGCNT2=DGCNT2+1
  1. ;D BMES^XPDUTL(DGCNT2_" codes have been added.")
  1. ;SUICIDE INDICATOR diagnoses
  1. D BMES^XPDUTL(" Adding SUICIDE INDICATOR entries...")
  1. S DGVAL(.01)=DGCATAR("SUICIDE INDICATOR")
  1. F DGY=1:1 S DGX=$P($T(DSUIC+DGY^DG53850C),";",3) Q:DGX="" D
  1. . S DGCNT1=DGCNT1+1
  1. . F DGY2=1:1 S DGX2=$P(DGX,",",DGY2) Q:DGX2="" D
  1. .. S DGVAL(.02)=(+$$CODEN^ICDEX(DGX2,80))_";ICD9("
  1. .. I $G(DGVAL(.02))=-1 D BMES^XPDUTL("Code "_DGX2_" was not found in the file #80") Q
  1. .. I $$INSREC(45.89,"",.DGVAL,DGIEN,,,,1)<0 D BMES^XPDUTL("Code "_DGX2_" was not added to the file #45.89")
  1. .. S DGIEN=DGIEN+1
  1. .. S DGCNT2=DGCNT2+1
  1. ;D BMES^XPDUTL(DGCNT2_" codes have been added.")
  1. ;KIDNEY TRANSPLANT STATUS diagnoses
  1. D BMES^XPDUTL(" Adding KIDNEY TRANSPLANT entries...")
  1. S DGVAL(.01)=DGCATAR("KIDNEY TRANSPLANT STATUS")
  1. F DGY=1:1 S DGX=$P($T(DKIDNEY+DGY^DG53850C),";",3) Q:DGX="" D
  1. . S DGCNT1=DGCNT1+1
  1. . F DGY2=1:1 S DGX2=$P(DGX,",",DGY2) Q:DGX2="" D
  1. .. S DGVAL(.02)=(+$$CODEN^ICDEX(DGX2,80))_";ICD9("
  1. .. I $G(DGVAL(.02))=-1 D BMES^XPDUTL("Code "_DGX2_" was not found in the file #80") Q
  1. .. I $$INSREC(45.89,"",.DGVAL,DGIEN,,,,1)<0 D BMES^XPDUTL("Code "_DGX2_" was not added to the file #45.89")
  1. .. S DGIEN=DGIEN+1
  1. .. S DGCNT2=DGCNT2+1
  1. D BMES^XPDUTL(" "_DGCNT2_" codes have been added.")
  1. Q DGIEN
  1. ;
  1. PROC4589(DGIEN,DGCATAR) ;
  1. N DGY,DGX,DGY2,DGX2,DGCNT1,DGCNT2,DGVAL
  1. S (DGCNT1,DGCNT2)=0
  1. S DGVAL(.05)=31
  1. D BMES^XPDUTL(" Adding DIALYSIS TYPE entries...")
  1. S DGVAL(.01)=DGCATAR("DIALYSIS TYPE")
  1. F DGY=1:1 S DGX=$P($T(PDIAL+DGY^DG53850C),";",3) Q:DGX="" D
  1. . W "."
  1. . S DGCNT1=DGCNT1+1
  1. . F DGY2=1:1 S DGX2=$P(DGX,",",DGY2) Q:DGX2="" D
  1. .. S DGVAL(.02)=(+$$CODEN^ICDEX(DGX2,80.1))_";ICD0("
  1. .. I $G(DGVAL(.02))=-1 D BMES^XPDUTL("Code "_DGX2_" was not found in the file #80.1") Q
  1. .. I $$INSREC(45.89,"",.DGVAL,DGIEN,,,,1)<0 D BMES^XPDUTL("Code "_DGX2_" was not added to the file #45.89")
  1. .. S DGIEN=DGIEN+1
  1. .. S DGCNT2=DGCNT2+1
  1. D BMES^XPDUTL(" "_DGCNT2_" codes have been added.")
  1. Q DGIEN
  1. ;
  1. ;/**
  1. ;Creates a new entry (or node for multiple with .01 field)
  1. ;
  1. ;DGFILE - file/subfile number
  1. ;DGIEN - ien of the parent file entry in which the new subfile entry will be inserted
  1. ;DGZFDA - array with values for the fields
  1. ; format for DGZFDA:
  1. ; DGZFDA(.01)=value for #.01 field
  1. ; DGZFDA(3)=value for #3 field
  1. ;DGRECNO -(optional) specify IEN if you want specific value
  1. ; Note: "" then the system will assign the entry number itself.
  1. ;DGFLGS - FLAGS parameter for UPDATE^DIE
  1. ;DGLCKGL - fully specified global reference to lock
  1. ;DGLCKTM - time out for LOCK, if LOCKTIME=0 then the function will not lock the file
  1. ;DGNEWRE - optional, flag = if 1 then allow to create a new top level record
  1. ;
  1. ;output :
  1. ; positive number - record # created
  1. ; <=0 - failure
  1. ;
  1. ;Example:
  1. ;"6^564419;ICD0(^^^31" to create an entry with IEN=5000
  1. ;S ZZ(.01)=6,ZZ(.02)="564419;ICD0(",ZZ(.05)=31 W $$INSREC^DG53850C(45.89,"",.ZZ,5000,,,,1)
  1. INSREC(DGFILE,DGIEN,DGZFDA,DGRECNO,DGFLGS,DGLCKGL,DGLCKTM,DGNEWRE) ;*/
  1. I ('$G(DGFILE)) Q "0^Invalid parameter"
  1. I +$G(DGNEWRE)=0 I $G(DGRECNO)>0,'$G(DGIEN) Q "0^Invalid parameter"
  1. N DGSSI,DGIENS,DGERR,DGFDA
  1. N DGLOCK S DGLOCK=0
  1. I '$G(DGRECNO) N DGRECNO S DGRECNO=$G(DGRECNO)
  1. I DGIEN'="" S DGIENS="+1,"_DGIEN_"," I $L(DGRECNO)>0 S DGSSI(1)=+DGRECNO
  1. I DGIEN="" S DGIENS="+1," I $L(DGRECNO)>0 S DGSSI(1)=+DGRECNO
  1. M DGFDA(DGFILE,DGIENS)=DGZFDA
  1. I $L($G(DGLCKGL)) L +@DGLCKGL:(+$G(DGLCKTM)) S DGLOCK=$T I 'DGLOCK Q -2 ;lock failure
  1. D UPDATE^DIE($G(DGFLGS),"DGFDA","DGSSI","DGERR")
  1. I DGLOCK L -@DGLCKGL
  1. I $D(DGERR) Q -1 ;D BMES^XPDUTL($G(DGERR("DIERR",1,"TEXT",1),"Update Error")) Q -1
  1. Q +$G(DGSSI(1))
  1. ;
  1. ;populate fields
  1. ;Input:
  1. ;DGFILE file number
  1. ;DGFLD field number
  1. ;DGIENS ien string
  1. ;DGNEWVAL new value to file (internal format)
  1. ;Output:
  1. ;0^ DGNEWVAL^error if failure
  1. ;1^ DGNEWVAL if success
  1. FILLFLDS(DGFILE,DGFLD,DGIENS,DGNEWVAL) ;
  1. I '$G(DGFILE) Q "0^Invalid parameter"
  1. I '$G(DGFLD) Q "0^Invalid parameter"
  1. I '$G(DGIENS) Q "0^Invalid parameter"
  1. I $G(DGNEWVAL)="" Q "0^Null"
  1. N DGIENSTR,FDA,ERRARR
  1. S DGIENSTR=DGIENS_","
  1. S FDA(DGFILE,DGIENSTR,DGFLD)=DGNEWVAL
  1. D FILE^DIE("","FDA","ERRARR")
  1. I $D(ERRARR) Q "0^"_DGNEWVAL_"^"_ERRARR("DIERR",1,"TEXT",1)
  1. Q "1^"_DGNEWVAL
  1. ;