DGLOCK3 ;ALB/BOK,BAJ,JAM - PATIENT FILE MUMPS TRIGGER/DATA EDIT CHECKS ; 01/23/2006
;;5.3;Registration;**489,527,688,1014,1040**;Aug 13,1993;Build 15
; DG*5.3*688 BAJ 01/23/2006 Changed to support foreign confidential addresses
KILL S DGX=X I $D(^DPT(DFN,.32)) F DGKZ=0:0 S DGKZ=$O(DGBZ(DGKZ)) Q:'DGKZ S X=$P(^DPT(DFN,.32),"^",DGKZ),$P(^(.32),"^",DGKZ)="" I X]"" S DGIZ=$S(DGKZ=20:.32945,1:(DGKZ/10000+.3281)) I $D(^DD(2,DGIZ,1)) D KILL1
S X=DGX
Q
KILL1 F DGJZ=0:0 S DGJZ=$O(^DD(2,DGIZ,1,DGJZ)) Q:'DGJZ X ^(DGJZ,2)
Q
S1 K DGBZ F DGKZ=9:1:13,20 S DGBZ(DGKZ)=""
D KILL K DGBZ,DGIZ,DGJZ,DGKZ
Q
S2 K DGBZ F DGKZ=14:1:18 S DGBZ(DGKZ)=""
D KILL K DGBZ,DGIZ,DGJZ,DGKZ
Q
CAD ;Confidential Address Edit
I $S('$D(^DPT(DFN,.141)):1,$P(^(.141),U,9)'="Y":1,1:0) D
.D EN^DDIOL("Requirement for Confidential Address data not indicated...NO EDITING!","","$C(7),!?4") K X
Q
CADD ;Confidential Address Delete
;Called from input transform on Confidential Address fields
Q:'$D(^DPT(DFN,.141)) I $P(^(.141),"^",9)="N"!($P(^(.141),"^",1,6)="^^^^^") D Q
.N DGFDA,DGERR
.D CADM
.I $D(DGFDA) D
..N DGX
..S DGX=X
..D FILE^DIE("","DGFDA","DGERR")
..S X=DGX
;
ASK W !,"Do you want to delete all confidential address data" S %=2 D YN^DICN I %Y["?" W !,"Answer 'Y'es to remove confidential address information, 'N'o to leave data in file" G ASK
ASK1 ;
; DG*5.3*1040 - Set DGTMOT on timeout. Calling routine checks for this variable to process timeout and cleanup this variable
I $G(DTOUT) S DGTMOT=1
Q:%'=1
D EN^DGCLEAR(DFN,"CONF")
D CADM
N DGX
S DGX=X
D FILE^DIE("","DGFDA","DGERR")
S X=DGX
Q
CADM ;Delete data from Confidential Address Categories
I $D(^DPT(DFN,.14)) D
.N DGIEN
.S DGIEN=0
.F S DGIEN=$O(^DPT(DFN,.14,DGIEN)) Q:'DGIEN D
..S DGFDA(2.141,DGIEN_","_DFN_",",.01)=""
Q
CADD1 ;Confidential Address Delete
;Called from Confidential Address "DEL" nodes
I $D(^DPT(DFN,.141)),$P(^(.141),U,9)="Y" D
.D EN^DDIOL("Answer NO to the 'CONFIDENTIAL ADDRESS ACTIVE' prompt to delete.","","$C(7),!?4") K X
Q
;
COV(DGELG) ; Rule for deleting COLLATERAL OF VET eligibility code DG*5.3*1014;jam;
; Cannot delete COV if there is an active CCP assigned to the Patient
; Invoked by:
; DELETE TEST - .361 (PRIMARY ELIGIBILITY)
; - .01 (ELIGIBILITY CODE) of the PATIENT ELIGIBILITIES subfile (.0361)
; Input: DGELG - Eligibility code being deleted (Optional - defaults to Primary Elig Code, field .361)
;
I $G(DGELG)="" S DGELG=$$GET1^DIQ(2,DFN_",",.361,"I")
; OK if not deleting COLLATERAL OF VET
I DGELG'=$$FIND1^DIC(8,"","B","COLLATERAL OF VET") Q
N DGFLG,DGCCP
S (DGFLG,DGCCP)=0
F S DGCCP=$O(^DPT(DFN,5,DGCCP)) Q:'DGCCP I $G(^DPT(DFN,5,DGCCP,0))'="" D Q:DGFLG
. ; If CCP without an End Date - cannot delete COV
. I '$P(^DPT(DFN,5,DGCCP,0),"^",4) S DGFLG=1
I DGFLG D EN^DDIOL("This eligibility cannot be removed while there are active CCP(s) assigned to the Patient. Please advance to Data Group [2] on Screen <11.5> to remove the active CCP(s).") K X
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGLOCK3 3073 printed Dec 13, 2024@02:44:05 Page 2
DGLOCK3 ;ALB/BOK,BAJ,JAM - PATIENT FILE MUMPS TRIGGER/DATA EDIT CHECKS ; 01/23/2006
+1 ;;5.3;Registration;**489,527,688,1014,1040**;Aug 13,1993;Build 15
+2 ; DG*5.3*688 BAJ 01/23/2006 Changed to support foreign confidential addresses
KILL SET DGX=X
IF $DATA(^DPT(DFN,.32))
FOR DGKZ=0:0
SET DGKZ=$ORDER(DGBZ(DGKZ))
if 'DGKZ
QUIT
SET X=$PIECE(^DPT(DFN,.32),"^",DGKZ)
SET $PIECE(^(.32),"^",DGKZ)=""
IF X]""
SET DGIZ=$SELECT(DGKZ=20:.32945,1:(DGKZ/10000+.3281))
IF $DATA(^DD(2,DGIZ,1))
DO KILL1
+1 SET X=DGX
+2 QUIT
KILL1 FOR DGJZ=0:0
SET DGJZ=$ORDER(^DD(2,DGIZ,1,DGJZ))
if 'DGJZ
QUIT
XECUTE ^(DGJZ,2)
+1 QUIT
S1 KILL DGBZ
FOR DGKZ=9:1:13,20
SET DGBZ(DGKZ)=""
+1 DO KILL
KILL DGBZ,DGIZ,DGJZ,DGKZ
+2 QUIT
S2 KILL DGBZ
FOR DGKZ=14:1:18
SET DGBZ(DGKZ)=""
+1 DO KILL
KILL DGBZ,DGIZ,DGJZ,DGKZ
+2 QUIT
CAD ;Confidential Address Edit
+1 IF $SELECT('$DATA(^DPT(DFN,.141)):1,$PIECE(^(.141),U,9)'="Y":1,1:0)
Begin DoDot:1
+2 DO EN^DDIOL("Requirement for Confidential Address data not indicated...NO EDITING!","","$C(7),!?4")
KILL X
End DoDot:1
+3 QUIT
CADD ;Confidential Address Delete
+1 ;Called from input transform on Confidential Address fields
+2 if '$DATA(^DPT(DFN,.141))
QUIT
IF $PIECE(^(.141),"^",9)="N"!($PIECE(^(.141),"^",1,6)="^^^^^")
Begin DoDot:1
+3 NEW DGFDA,DGERR
+4 DO CADM
+5 IF $DATA(DGFDA)
Begin DoDot:2
+6 NEW DGX
+7 SET DGX=X
+8 DO FILE^DIE("","DGFDA","DGERR")
+9 SET X=DGX
End DoDot:2
End DoDot:1
QUIT
+10 ;
ASK WRITE !,"Do you want to delete all confidential address data"
SET %=2
DO YN^DICN
IF %Y["?"
WRITE !,"Answer 'Y'es to remove confidential address information, 'N'o to leave data in file"
GOTO ASK
ASK1 ;
+1 ; DG*5.3*1040 - Set DGTMOT on timeout. Calling routine checks for this variable to process timeout and cleanup this variable
+2 IF $GET(DTOUT)
SET DGTMOT=1
+3 if %'=1
QUIT
+4 DO EN^DGCLEAR(DFN,"CONF")
+5 DO CADM
+6 NEW DGX
+7 SET DGX=X
+8 DO FILE^DIE("","DGFDA","DGERR")
+9 SET X=DGX
+10 QUIT
CADM ;Delete data from Confidential Address Categories
+1 IF $DATA(^DPT(DFN,.14))
Begin DoDot:1
+2 NEW DGIEN
+3 SET DGIEN=0
+4 FOR
SET DGIEN=$ORDER(^DPT(DFN,.14,DGIEN))
if 'DGIEN
QUIT
Begin DoDot:2
+5 SET DGFDA(2.141,DGIEN_","_DFN_",",.01)=""
End DoDot:2
End DoDot:1
+6 QUIT
CADD1 ;Confidential Address Delete
+1 ;Called from Confidential Address "DEL" nodes
+2 IF $DATA(^DPT(DFN,.141))
IF $PIECE(^(.141),U,9)="Y"
Begin DoDot:1
+3 DO EN^DDIOL("Answer NO to the 'CONFIDENTIAL ADDRESS ACTIVE' prompt to delete.","","$C(7),!?4")
KILL X
End DoDot:1
+4 QUIT
+5 ;
COV(DGELG) ; Rule for deleting COLLATERAL OF VET eligibility code DG*5.3*1014;jam;
+1 ; Cannot delete COV if there is an active CCP assigned to the Patient
+2 ; Invoked by:
+3 ; DELETE TEST - .361 (PRIMARY ELIGIBILITY)
+4 ; - .01 (ELIGIBILITY CODE) of the PATIENT ELIGIBILITIES subfile (.0361)
+5 ; Input: DGELG - Eligibility code being deleted (Optional - defaults to Primary Elig Code, field .361)
+6 ;
+7 IF $GET(DGELG)=""
SET DGELG=$$GET1^DIQ(2,DFN_",",.361,"I")
+8 ; OK if not deleting COLLATERAL OF VET
+9 IF DGELG'=$$FIND1^DIC(8,"","B","COLLATERAL OF VET")
QUIT
+10 NEW DGFLG,DGCCP
+11 SET (DGFLG,DGCCP)=0
+12 FOR
SET DGCCP=$ORDER(^DPT(DFN,5,DGCCP))
if 'DGCCP
QUIT
IF $GET(^DPT(DFN,5,DGCCP,0))'=""
Begin DoDot:1
+13 ; If CCP without an End Date - cannot delete COV
+14 IF '$PIECE(^DPT(DFN,5,DGCCP,0),"^",4)
SET DGFLG=1
End DoDot:1
if DGFLG
QUIT
+15 IF DGFLG
DO EN^DDIOL("This eligibility cannot be removed while there are active CCP(s) assigned to the Patient. Please advance to Data Group [2] on Screen <11.5> to remove the active CCP(s).")
KILL X
+16 QUIT
