- DGENCDA2 ;ALB/CJM,ISA/KWP,Zoltan,JAN,CKN - Catastrophic Disabilty API - File Data;May 24, 1999,Nov 14, 2001 ; 9/22/05 5:40pm
- ;;5.3;Registration;**232,387,653,1015**;Aug 13,1993;Build 21
- ;
- STORE(DFN,DGCDIS,ERROR) ;
- ;Description: Creates a catastrophic disability record for a patient.
- ; Attempts to add catastrophically disabled eligibility code.
- ;Input:
- ; DFN - Patient IEN
- ; DGCDIS - the catastrophic disability array, passed by reference
- ;Output:
- ; Function Value - returns 1 if successful, otherwise 0
- ; ERROR - if not successful, an error message is returned,pass
- ; by reference
- N SUCCESS,FDA,SUB,HIEN,HSUB,FDB,NIEN,EIEN
- S SUCCESS=1
- S ERROR=""
- D ;drops out if invalid condition found
- . I $G(DFN),$D(^DPT(DFN,0))
- . E S SUCCESS=0,ERROR="PATIENT NOT FOUND" Q
- . I '$$LOCK^DGENCDA1(DFN) S SUCCESS=0,ERROR="RECORD IN USE, CAN NOT BE EDITED" Q
- . I '$$CHECK^DGENCDA1(.DGCDIS,.ERROR) S SUCCESS=0 Q
- . S HIEN=$P($G(^DPT(DFN,.399,0)),"^",3)+1
- . S HIEN=HIEN_","_DFN_","
- . S FDA(2,DFN_",",.39)=DGCDIS("VCD")
- . S FDB(2.399,HIEN,.39)=DGCDIS("VCD")
- . S FDA(2,DFN_",",.391)=DGCDIS("BY")
- . S FDB(2.399,HIEN,.391)=DGCDIS("BY")
- . S FDA(2,DFN_",",.392)=DGCDIS("DATE")
- . S FDB(2.399,HIEN,.392)=DGCDIS("DATE")
- . S FDA(2,DFN_",",.393)=DGCDIS("FACDET")
- . S FDB(2.399,HIEN,.393)=DGCDIS("FACDET")
- . S FDA(2,DFN_",",.394)=DGCDIS("REVDTE")
- . S FDB(2.399,HIEN,.394)=DGCDIS("REVDTE")
- . S FDA(2,DFN_",",.395)=DGCDIS("METDET")
- . S FDB(2.399,HIEN,.395)=DGCDIS("METDET")
- . S FDA(2,DFN_",",.3951)=DGCDIS("VETREQDT")
- . S FDB(2.399,HIEN,.3951)=DGCDIS("VETREQDT")
- . S FDA(2,DFN_",",.3952)=DGCDIS("DTFACIRV")
- . S FDB(2.399,HIEN,.3952)=DGCDIS("DTFACIRV")
- . S FDA(2,DFN_",",.3953)=DGCDIS("DTVETNOT")
- . S FDB(2.399,HIEN,.3953)=DGCDIS("DTVETNOT")
- . S SUB="",HSUB=0
- . S NIEN=0 F S SUB=$O(DGCDIS("DIAG",SUB)) Q:'SUB D
- . . I DGCDIS("DIAG",SUB)="" Q
- . . S NIEN=NIEN+1
- . . S FDB(2.396,NIEN_","_DFN_",",.01)=DGCDIS("DIAG",SUB)
- . . S HSUB=HSUB+1
- . . S FDB(2.409,HSUB_","_HIEN,.01)=DGCDIS("DIAG",SUB)
- . S NIEN=0 F S SUB=$O(DGCDIS("PROC",SUB)) Q:'SUB D
- . . I DGCDIS("PROC",SUB)="" Q
- . . S EIEN=0 F S EIEN=$O(DGCDIS("EXT",SUB,EIEN)) Q:'EIEN D
- . . . S NIEN=NIEN+1
- . . . S FDB(2.397,NIEN_","_DFN_",",.01)=DGCDIS("PROC",SUB)
- . . . S HSUB=HSUB+1
- . . . S FDB(2.409,HSUB_","_HIEN,.01)=DGCDIS("PROC",SUB)
- . . . S FDB(2.397,NIEN_","_DFN_",",1)=DGCDIS("EXT",SUB,EIEN)
- . . . S FDB(2.409,HSUB_","_HIEN,1)=DGCDIS("EXT",SUB,EIEN)
- . S NIEN=0 F S SUB=$O(DGCDIS("COND",SUB)) Q:'SUB D
- . . I DGCDIS("COND",SUB)="" Q
- . . S NIEN=NIEN+1
- . . S FDB(2.398,NIEN_","_DFN_",",.01)=DGCDIS("COND",SUB)
- . . S HSUB=HSUB+1
- . . S FDB(2.409,HSUB_","_HIEN,.01)=DGCDIS("COND",SUB)
- . . S FDB(2.398,NIEN_","_DFN_",",1)=DGCDIS("SCORE",SUB)
- . . S FDB(2.409,HSUB_","_HIEN,2)=DGCDIS("SCORE",SUB)
- . . S FDB(2.398,NIEN_","_DFN_",",2)=DGCDIS("PERM",SUB)
- . . S FDB(2.409,HSUB_","_HIEN,3)=DGCDIS("PERM",SUB)
- . S FDB(2.399,HIEN,.01)=$$NOW^XLFDT
- I SUCCESS D
- . N SUBFDA,SUBFILE
- . S SUCCESS=$$DELETE^DGENCDA1(DFN)
- . Q:'SUCCESS
- . D FILE^DIE("K","FDA","DGCDERR")
- . I $G(DIERR) D Q
- . . S ERROR="FILEMAN UNABLE TO PERFORM UPDATE"
- . . S SUCCESS=0
- . . D ERRDISP^DGENCDA1(2)
- . S SUBFILE=""
- . S ERROR="FILEMAN UPDATE FAILED FOR "
- . F S SUBFILE=$O(FDB(SUBFILE)) Q:SUBFILE="" D Q:'SUCCESS
- . . N IEN,NODE,ITEM
- . . S IEN=""
- . . F ITEM=0:1 S IEN=$O(FDB(SUBFILE,IEN)) Q:'IEN D Q:'SUCCESS
- . . . N DIC,Y,DO,DD,DINUM,DA,NODE
- . . . I SUBFILE'=2.409 D
- . . . . S NODE=SUBFILE-2
- . . . . S DIC("P")=$P($G(^DD(2,SUBFILE-2,0)),"^",2)
- . . . . S DA(1)=DFN
- . . . E D
- . . . . S NODE=".399,"_$P(IEN,",",2)_",1"
- . . . . S DIC("P")=$P($G(^DD(2.399,.396,0)),"^",2)
- . . . . S DA(1)=$P(IEN,",",2),DA(2)=DFN
- . . . S DIC="^DPT("_DFN_","_NODE_","
- . . . S DIC(0)="L"
- . . . S X=FDB(SUBFILE,IEN,.01)
- . . . S DINUM=+IEN
- . . . D FILE^DICN
- . . . I Y=-1 S ERROR="FAILED TO ADD ENTRY TO #"_SUBFILE,SUCCESS=0
- . . Q:'SUCCESS
- . . K SUBFDA
- . . M SUBFDA(SUBFILE)=FDB(SUBFILE)
- . . D FILE^DIE("K","SUBFDA","DGCDERR")
- . . I $G(DIERR) D
- . . . S ERROR=ERROR_" #"_SUBFILE
- . . . S SUCCESS=0
- . . . D ERRDISP^DGENCDA1(SUBFILE)
- . I SUCCESS S ERROR=""
- D CLEAN^DILF
- D UNLOCK^DGENCDA1(DFN)
- Q SUCCESS
- DGENCDA2 ;ALB/CJM,ISA/KWP,Zoltan,JAN,CKN - Catastrophic Disabilty API - File Data;May 24, 1999,Nov 14, 2001 ; 9/22/05 5:40pm
- +1 ;;5.3;Registration;**232,387,653,1015**;Aug 13,1993;Build 21
- +2 ;
- STORE(DFN,DGCDIS,ERROR) ;
- +1 ;Description: Creates a catastrophic disability record for a patient.
- +2 ; Attempts to add catastrophically disabled eligibility code.
- +3 ;Input:
- +4 ; DFN - Patient IEN
- +5 ; DGCDIS - the catastrophic disability array, passed by reference
- +6 ;Output:
- +7 ; Function Value - returns 1 if successful, otherwise 0
- +8 ; ERROR - if not successful, an error message is returned,pass
- +9 ; by reference
- +10 NEW SUCCESS,FDA,SUB,HIEN,HSUB,FDB,NIEN,EIEN
- +11 SET SUCCESS=1
- +12 SET ERROR=""
- +13 ;drops out if invalid condition found
- Begin DoDot:1
- +14 IF $GET(DFN)
- IF $DATA(^DPT(DFN,0))
- +15 IF '$TEST
- SET SUCCESS=0
- SET ERROR="PATIENT NOT FOUND"
- QUIT
- +16 IF '$$LOCK^DGENCDA1(DFN)
- SET SUCCESS=0
- SET ERROR="RECORD IN USE, CAN NOT BE EDITED"
- QUIT
- +17 IF '$$CHECK^DGENCDA1(.DGCDIS,.ERROR)
- SET SUCCESS=0
- QUIT
- +18 SET HIEN=$PIECE($GET(^DPT(DFN,.399,0)),"^",3)+1
- +19 SET HIEN=HIEN_","_DFN_","
- +20 SET FDA(2,DFN_",",.39)=DGCDIS("VCD")
- +21 SET FDB(2.399,HIEN,.39)=DGCDIS("VCD")
- +22 SET FDA(2,DFN_",",.391)=DGCDIS("BY")
- +23 SET FDB(2.399,HIEN,.391)=DGCDIS("BY")
- +24 SET FDA(2,DFN_",",.392)=DGCDIS("DATE")
- +25 SET FDB(2.399,HIEN,.392)=DGCDIS("DATE")
- +26 SET FDA(2,DFN_",",.393)=DGCDIS("FACDET")
- +27 SET FDB(2.399,HIEN,.393)=DGCDIS("FACDET")
- +28 SET FDA(2,DFN_",",.394)=DGCDIS("REVDTE")
- +29 SET FDB(2.399,HIEN,.394)=DGCDIS("REVDTE")
- +30 SET FDA(2,DFN_",",.395)=DGCDIS("METDET")
- +31 SET FDB(2.399,HIEN,.395)=DGCDIS("METDET")
- +32 SET FDA(2,DFN_",",.3951)=DGCDIS("VETREQDT")
- +33 SET FDB(2.399,HIEN,.3951)=DGCDIS("VETREQDT")
- +34 SET FDA(2,DFN_",",.3952)=DGCDIS("DTFACIRV")
- +35 SET FDB(2.399,HIEN,.3952)=DGCDIS("DTFACIRV")
- +36 SET FDA(2,DFN_",",.3953)=DGCDIS("DTVETNOT")
- +37 SET FDB(2.399,HIEN,.3953)=DGCDIS("DTVETNOT")
- +38 SET SUB=""
- SET HSUB=0
- +39 SET NIEN=0
- FOR
- SET SUB=$ORDER(DGCDIS("DIAG",SUB))
- IF 'SUB
- QUIT
- Begin DoDot:2
- +40 IF DGCDIS("DIAG",SUB)=""
- QUIT
- +41 SET NIEN=NIEN+1
- +42 SET FDB(2.396,NIEN_","_DFN_",",.01)=DGCDIS("DIAG",SUB)
- +43 SET HSUB=HSUB+1
- +44 SET FDB(2.409,HSUB_","_HIEN,.01)=DGCDIS("DIAG",SUB)
- End DoDot:2
- +45 SET NIEN=0
- FOR
- SET SUB=$ORDER(DGCDIS("PROC",SUB))
- IF 'SUB
- QUIT
- Begin DoDot:2
- +46 IF DGCDIS("PROC",SUB)=""
- QUIT
- +47 SET EIEN=0
- FOR
- SET EIEN=$ORDER(DGCDIS("EXT",SUB,EIEN))
- IF 'EIEN
- QUIT
- Begin DoDot:3
- +48 SET NIEN=NIEN+1
- +49 SET FDB(2.397,NIEN_","_DFN_",",.01)=DGCDIS("PROC",SUB)
- +50 SET HSUB=HSUB+1
- +51 SET FDB(2.409,HSUB_","_HIEN,.01)=DGCDIS("PROC",SUB)
- +52 SET FDB(2.397,NIEN_","_DFN_",",1)=DGCDIS("EXT",SUB,EIEN)
- +53 SET FDB(2.409,HSUB_","_HIEN,1)=DGCDIS("EXT",SUB,EIEN)
- End DoDot:3
- End DoDot:2
- +54 SET NIEN=0
- FOR
- SET SUB=$ORDER(DGCDIS("COND",SUB))
- IF 'SUB
- QUIT
- Begin DoDot:2
- +55 IF DGCDIS("COND",SUB)=""
- QUIT
- +56 SET NIEN=NIEN+1
- +57 SET FDB(2.398,NIEN_","_DFN_",",.01)=DGCDIS("COND",SUB)
- +58 SET HSUB=HSUB+1
- +59 SET FDB(2.409,HSUB_","_HIEN,.01)=DGCDIS("COND",SUB)
- +60 SET FDB(2.398,NIEN_","_DFN_",",1)=DGCDIS("SCORE",SUB)
- +61 SET FDB(2.409,HSUB_","_HIEN,2)=DGCDIS("SCORE",SUB)
- +62 SET FDB(2.398,NIEN_","_DFN_",",2)=DGCDIS("PERM",SUB)
- +63 SET FDB(2.409,HSUB_","_HIEN,3)=DGCDIS("PERM",SUB)
- End DoDot:2
- +64 SET FDB(2.399,HIEN,.01)=$$NOW^XLFDT
- End DoDot:1
- +65 IF SUCCESS
- Begin DoDot:1
- +66 NEW SUBFDA,SUBFILE
- +67 SET SUCCESS=$$DELETE^DGENCDA1(DFN)
- +68 IF 'SUCCESS
- QUIT
- +69 DO FILE^DIE("K","FDA","DGCDERR")
- +70 IF $GET(DIERR)
- Begin DoDot:2
- +71 SET ERROR="FILEMAN UNABLE TO PERFORM UPDATE"
- +72 SET SUCCESS=0
- +73 DO ERRDISP^DGENCDA1(2)
- End DoDot:2
- QUIT
- +74 SET SUBFILE=""
- +75 SET ERROR="FILEMAN UPDATE FAILED FOR "
- +76 FOR
- SET SUBFILE=$ORDER(FDB(SUBFILE))
- IF SUBFILE=""
- QUIT
- Begin DoDot:2
- +77 NEW IEN,NODE,ITEM
- +78 SET IEN=""
- +79 FOR ITEM=0:1
- SET IEN=$ORDER(FDB(SUBFILE,IEN))
- IF 'IEN
- QUIT
- Begin DoDot:3
- +80 NEW DIC,Y,DO,DD,DINUM,DA,NODE
- +81 IF SUBFILE'=2.409
- Begin DoDot:4
- +82 SET NODE=SUBFILE-2
- +83 SET DIC("P")=$PIECE($GET(^DD(2,SUBFILE-2,0)),"^",2)
- +84 SET DA(1)=DFN
- End DoDot:4
- +85 IF '$TEST
- Begin DoDot:4
- +86 SET NODE=".399,"_$PIECE(IEN,",",2)_",1"
- +87 SET DIC("P")=$PIECE($GET(^DD(2.399,.396,0)),"^",2)
- +88 SET DA(1)=$PIECE(IEN,",",2)
- SET DA(2)=DFN
- End DoDot:4
- +89 SET DIC="^DPT("_DFN_","_NODE_","
- +90 SET DIC(0)="L"
- +91 SET X=FDB(SUBFILE,IEN,.01)
- +92 SET DINUM=+IEN
- +93 DO FILE^DICN
- +94 IF Y=-1
- SET ERROR="FAILED TO ADD ENTRY TO #"_SUBFILE
- SET SUCCESS=0
- End DoDot:3
- IF 'SUCCESS
- QUIT
- +95 IF 'SUCCESS
- QUIT
- +96 KILL SUBFDA
- +97 MERGE SUBFDA(SUBFILE)=FDB(SUBFILE)
- +98 DO FILE^DIE("K","SUBFDA","DGCDERR")
- +99 IF $GET(DIERR)
- Begin DoDot:3
- +100 SET ERROR=ERROR_" #"_SUBFILE
- +101 SET SUCCESS=0
- +102 DO ERRDISP^DGENCDA1(SUBFILE)
- End DoDot:3
- End DoDot:2
- IF 'SUCCESS
- QUIT
- +103 IF SUCCESS
- SET ERROR=""
- End DoDot:1
- +104 DO CLEAN^DILF
- +105 DO UNLOCK^DGENCDA1(DFN)
- +106 QUIT SUCCESS
