DGRP1152A ;ALB/LEG - REGISTRATION SCREEN 11.5.2/VERIFICATION INFORMATION ;JUN 08, 2020@23:00
;;5.3;Registration;**1014**;AUG 13, 1993;Build 42
;=======================================================================================
EN(DFN) ;Main entry point to invoke the DGEN CCP DETAIL list
; Input -- DFN Patient IEN
D WAIT^DICD
D EN^VALM("DGEN CCP DETAIL")
N VALMHDR,VALMBCK,VALMSG,VALMCNT
Q
;
HDR ;Header code
N DGDOB,DGPTYPE,DGSSNSTR,DGSSN
N DGBLANKS,DGMEMID,DGNAME,DGPREFNM,DGPTYPE,DGTMP
K VALMHDR
S DGDOB=$$GET1^DIQ(2,DFN,.03,"I")
S DGDOB=$$UP^XLFSTR($$FMTE^XLFDT($E(DGDOB,1,12),1))
S DGSSNSTR=$$SSNNM^DGRPU(DFN)
S DGSSN=$P($P(DGSSNSTR,";",2)," ",3)
S DGPTYPE=$$GET1^DIQ(391,$$GET1^DIQ(2,DFN_",",391,"I")_",",.01)
S:DGPTYPE="" DGPTYPE="PATIENT TYPE UNKNOWN"
S VALMHDR(1)=$P(DGSSNSTR,";",1)_$S($$GET1^DIQ(2,DFN,.2405)'="":" ("_$$GET1^DIQ(2,DFN,.2405)_")",1:"")_" "_DGDOB
S VALMHDR(2)=$S($P($P(DGSSNSTR,";",2)," ",2)'="":$E($P($P(DGSSNSTR,";",2)," ",2),1,40)_" ",1:"")_DGSSN_" "_DGPTYPE
S VALMHDR(3)=$J("",5)_"CCP Name"_$J("",20)_"Effective Date"
Q
;
INIT ;Build patient Collateral screen
D CLEAN^VALM10
D CLEAR^VALM1
D TMP^DGRP1152U(.DGTMP)
Q
;
EXIT ;Exit code
D CLEAN^VALM10
D CLEAR^VALM1
K DGTMP,^TMP("VALM DATA",$J)
Q
;
PEXIT ;DGEN CCP MENU protocol exit code
;Reset after page up or down
S VALMSG="+ Next Screen - Prev Screen ?? More Actions"
Q
;
HELP ; Invoked from HELP CODE in List Template [DGEN CCP DETAIL]
S X="?" D DISP^XQORM1
S VALMSG="+ Next Screen - Prev Screen ?? More Actions"
Q
;
ACT(DGACT) ; Entry point for menu action selection
; INPUT: DGACT = "A" - Add - DGEN CCP ADD protocol
; = "E" - Edit - DGEN CCP EDIT protocol
; = "R" - Remove - DGEN CCP REMOVE protocol
N DGX,DA,DIE,DIC,DIK,DIPA,DR
I $G(DGACT)="" G ACTQ
; DGRPV represents the "VIEW" or "EDIT" status that is created in routine DGRPV
I $G(DGRPV) D FULL^VALM1 W !,"View only. This action cannot be selected." D PAUSE^VALM1 G ACTQ
D FULL^VALM1
I DGACT="A" D ADD,ACTQ Q
I DGACT="E" D EDIT,ACTQ Q
I DGACT="R" D REMOVE,ACTQ Q
Q
;
ACTQ ; menu action exit point
S VALMBCK="R"
D TMP^DGRP1152U(.DGTMP)
Q
;
ADD ; Add new CCP to #1910 sub-file
N DGCCPCD,DGEFFDT
I '$$ADASKCCP(.DGCCPCD) Q
I '$$ADASKEFDT(DGCCPCD,.DGEFFDT) Q
N DIR,X,Y,DTOUT,DUOUT,DIROUT,DIRUT,DGCCPNM
S DGCCPNM=$$EXTERNAL^DILFD(2.191,1,"",DGCCPCD)
S DIR(0)="Y",DIR("A")="Are you adding '"_DGCCPNM_"' as a new CCP",DIR("B")="NO"
D ^DIR I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT)!'Y Q
D SAVREC(DFN,DGCCPCD,DGEFFDT) ;saves new record
Q
;
EDIT ;EDIT EXISTING CCP
N DGSEL,DGORIGIDX,DGORIGREC,DGCCPCD,DGEFFDT
S DGSEL=$$SELECT("E",.DGORIGIDX,.DGORIGREC) Q:'DGSEL
I '$$EDASKCCP(DGORIGIDX,.DGCCPCD) Q
I '$$EDASKEFDT(DGORIGIDX,DGORIGREC,DGCCPCD,.DGEFFDT) Q
D SAVREC(DFN,DGCCPCD,DGEFFDT) ;saves new record
D SAVENDT(DGORIGIDX) ; set END DATE into originally edited record
Q
;
REMOVE ;REMOVE EXISTING CCP
N DGSEL,DGORIGIDX
S DGSEL=$$SELECT("R",.DGORIGIDX) Q:'DGSEL
N DIR,Y,DTOUT,DUOUT,DIROUT,DIRUT
S DIR(0)="Y",DIR("A")="Are you sure you want to remove this CCP entry",DIR("B")="NO"
D ^DIR I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT)!'Y Q
D SAVENDT(DGORIGIDX) ; set END DATE into removed record
Q
;
SELECT(DGACT,DGORIGIDX,DGORIGREC) ;
; Input: DGACT - "E"dit or "R"emove
; Output: DGORIGIDX - (Pass by reference) The entry number of the selected CCP
; DGORIGREC - (Pass by reference) The fields of the selected CCP
; Returns the entry number selected
;
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y,DGRECS,DGSEL
S DGRECS=$O(DGTMP("IDX",""),-1)
I 'DGRECS D Q 0
. W !,"There are no entries to "_$S(DGACT="E":"edit.",1:"remove.")
. D PAUSE^VALM1
S DIR(0)="NA^1:"_DGRECS_":0"
S DIR("A",1)="",DIR("A")="Select Entry (1-"_DGRECS_"): " D ^DIR K DIR
S DGSEL=Y
I $D(DTOUT)!$D(DUOUT) Q 0
; translate the display [num] to the ^DPT(DFN,5,IDX)
S DGORIGIDX=$O(DGTMP("IDX",DGSEL,"")),DGORIGREC=^DPT(DFN,5,DGORIGIDX,0)
Q DGSEL
;
ADASKCCP(DGCCPCD) ; Prompts for CCP to be ADDed
; Output: DGCCPCD - CCP Code to be added (Pass by Reference)
; Returns - TRUE if valid CCP entered
;
N DIR,DTOUT,DUOUT,DGGOOD,Y,X
L1 ; Tag to call for re-prompting
S DIR(0)="2.191,1,A,O^^"
S DIR("A")="Add CCP: "
D ^DIR
K DIR
I $D(DUOUT)!$D(DTOUT) Q 0
I Y="" Q 0
S DGCCPCD=Y
D CHKMULT1(DFN,DGCCPCD,.DGGOOD)
I 'DGGOOD W " ** Already have this CCP on file." G L1
Q 1
;
EDASKCCP(DGORIGIDX,DGCCPCD) ; ASK EDIT CCP
; Input: DGORIGIDX - Entry number of the CCP selected for edit
; Output: DGCCPCD - The CCP Code that has been entered {Pass by Reference)
; Returns: TRUE is edit of the CCP was successful
;
N DIR,DGENTRY,DTOUT,DUOUT,DGGOOD,X,Y
L2 ; Tag to call for re-prompting
S DIR("B")=$$GET1^DIQ(2.191,DGORIGIDX_","_DFN_",",1)
S DIR(0)="2.191,1,A,r^^"
S DIR("A")="CCP: "
D ^DIR
K DIR
I $D(DUOUT)!$D(DTOUT) Q 0
S DGCCPCD=Y
D CHKMULT1(DFN,DGCCPCD,.DGGOOD)
I 'DGGOOD W " ** Already have this CCP on file." G L2
Q 1
;
ADASKEFDT(DGCCPCD,DGEFFDT) ; ASK ADD EFFECTIVE DATE AND IF VALID SAVE
; Input: DGCCPCD - CCP Code associated with the effective date
; Outut: DGEFFDT - Effective date entered for this CCP (Pass by Reference)
; Returns TRUE if valid effective date added for this CCP
;
N DIR,DTOUT,DUOUT,Y,X,DGGOOD,DGEXDT,X,Y
; Sets DGEFFDT for the CCP to be added
;
L3 ; Tag to call for re-prompting
S DIR(0)="2.191,2,A^^"
S DIR("A")="Enter EFFECTIVE DATE: "
S DIR("B")="T"
K X,Y
D ^DIR
I $D(DUOUT)!$D(DTOUT) Q 0
I +Y<1 Q 0
I Y,$L(Y(0))=10 S Y(0)=$P(Y(0)," ")_" 0"_$P(Y(0)," ",2)
S DGEFFDT=Y,DGEXDT=Y(0)
I '$L(DGEXDT) W:Y<0 " '"_X_"' is not a valid date." G L3
D CHKMULT2(DFN,DGCCPCD,DGEFFDT,.DGGOOD)
I 'DGGOOD D MULTERR^DGRP1152U G L3
Q 1
;
EDASKEFDT(DGORIGIDX,DGORIGREC,DGCCPCD,DGEFFDT) ; ASK EFFECTIVE DATE AND IF VALID SAVE
; Input: DGORIGIDX - Entry number of the CCP selected for edit
; DGORIGREC - The fields of the selected CCP (0 node)
; DGCCPCD - CCP code for the associated Effective Date
; Input: DGEFFDT - Updated Effective Date (Pass by reference)
; Returns: TRUE is edit of Effective Date was successful
;
N DIR,DTOUT,DUOUT,Y,X,DGGOOD,DGEXDT
L4 ; Tag to call for re-prompting
S DIR(0)="2.191,2,A,r^^"
S DIR("A")="Enter EFFECTIVE DATE: "
S DIR("B")=$$GET1^DIQ(2.191,DGORIGIDX_","_DFN_",",2)
K X,Y
D ^DIR
I $D(DUOUT)!$D(DTOUT) Q 0
I +Y<1 Q 0
I Y,$L(Y(0))=10 S Y(0)=$P(Y(0)," ")_" 0"_$P(Y(0)," ",2)
S DGEFFDT=Y,DGEXDT=Y(0)
I '$L(DGEXDT) W:Y<0 " '"_X_"' is not a valid date." G L4
; If the edited CCP/Date matches the original CCP/Date quit - no changes
I (DGCCPCD_"^"_DGEFFDT)=$P(DGORIGREC,U,2,3) Q 0
D CHKMULT2(DFN,DGCCPCD,DGEFFDT,.DGGOOD)
I 'DGGOOD D MULTERR^DGRP1152U G L4
Q 1
;
CHKMULT1(DFN,DGCCP,DGGOOD) ; checks for disallowed 'A' or 'I' multiples
; Input: DFN
; DGCCCP - The CPP code to check
; Output: DGGOOD - (Pass by Reference) - TRUE if OK
;
N DGI,DGTIDX,DGTREC,DGTCCP,DGTENDT
S DGGOOD=1
I $L(DGCCP)'=1 Q
; checks for duplicate CCP if "ART/IVF" or "NEWBORN"
I "AI"[DGCCP D Q
. S DGTIDX=0,DGI=""
. F S DGI=$O(DGTMP("IDX",DGI)) Q:'DGI S DGTIDX=$O(DGTMP("IDX",DGI,"")) Q:'DGTIDX I DGI'=$G(DGSEL) S DGTREC=$G(DGTMP("IDX",DGI,DGTIDX)) Q:DGTREC="" D Q:'DGGOOD
. . S DGTCCP=$P(DGTREC,U,2),DGTENDT=$P(DGTREC,U,4)
. . I DGTCCP=DGCCP,'DGTENDT S DGGOOD=0
Q
;
CHKMULT2(DFN,DGCCP,DGFMDT,DGGOOD) ; checks for disallowed same CCP with same EFFECTIVE DATE
; Input: DFN
; DGCCCP - The CPP code to check
; DGFMDT - Effective Date to check (Fileman format)
; Output: DGGOOD - (Pass by Reference) - TRUE if OK
;
N DGTIDX,DGTCCP,DGTENDT,DGTREC
S DGGOOD=1
I $L(DGCCP)'=1 Q
; checks for duplicate date for same CCP
I "?CT"[DGCCP,DGFMDT D
. S DGTIDX=""
. F S DGTIDX=$O(DGTMP("EFDT",DGFMDT,DGTIDX)) Q:'DGTIDX D Q:'DGGOOD
. . S DGTREC=DGTMP("EFDT",DGFMDT,DGTIDX)
. . S DGTCCP=$P(DGTREC,U,2)
. . S DGTENDT=$P(DGTREC,U,4)
. . I DGTCCP=DGCCP,'DGTENDT S DGGOOD=0
Q
;
SAVREC(DFN,DGCCPCD,DGEFFDT) ;save newly ADDed or EDITed record
;
; If this combination of Code and Effective date already exists in an End-Dated record, it will be reactivated
I $$SAVEXIST(DFN,DGCCPCD,DGEFFDT) Q
; Otherwise, save a new record
N %,Y,X,DGERR,DGIENS,DGFDA
S DGERR=0
S DGIENS=DFN_","
S DGIENS="+1,"_DGIENS
D NOW^%DTC
S DGFDA(2.191,DGIENS,.01)=%
S DGFDA(2.191,DGIENS,1)=DGCCPCD
S DGFDA(2.191,DGIENS,2)=DGEFFDT
D UPDATE^DIE("","DGFDA","","DGERR")
I DGERR W " **UNABLE TO SAVE**"
Q
;
SAVEXIST(DFN,DGCCP,DGFMDT) ; Check for an existing CCP record to be saved
; Checks for a matching CCP/EFFECTIVE DATE record among the End Dated CCPs. If found, reuse it (Remove the end date)
; Inputs: DFN - Patient DFN
; DGCCP - CCP Code
; DGFMDT - CCP Effective date
; Returns: The Entry number of the reactivated CCP if found or NULL
;
N DGTIDX,DGTCCP,DGTENDT,DGTREC,DGEXIST,DGERR,DGFDA
I $L(DGCCP)'=1!('DGFMDT) Q ""
; For the effective date, check for a matching CCP - (the record should be end dated since there cannot be duplicate effective dates for an active CCP)
S (DGEXIST,DGTIDX)=""
F S DGTIDX=$O(DGTMP("EFDT",DGFMDT,DGTIDX)) Q:'DGTIDX D Q:DGEXIST
. S DGTREC=DGTMP("EFDT",DGFMDT,DGTIDX)
. ; Don't check archived records
. I $P(DGTREC,U,5) Q
. S DGTCCP=$P(DGTREC,U,2)
. S DGTENDT=$P(DGTREC,U,4)
. I DGTCCP=DGCCP,DGTENDT'="" D
. . ; Matching record found
. . S DGEXIST=DGTIDX
. . ; Set the LAST DATE UPDATED and Clear the End Date
. . S DGFDA(2.191,DGTIDX_","_DFN_",",.01)=$$NOW^XLFDT()
. . S DGFDA(2.191,DGTIDX_","_DFN_",",3)=""
. . D FILE^DIE("","DGFDA","DGERR")
Q DGEXIST
;
SAVENDT(DGSIDX) ;save END DATE in old rec
; Input: DGSIDX - Entry number of the CCP to set End Date
;
N DGERR,DGFDA,X
; CCP LAST UPDATED DATE
S DGFDA(2.191,DGSIDX_","_DFN_",",.01)=$$NOW^XLFDT()
; END DATE
D NOW^%DTC
S DGFDA(2.191,DGSIDX_","_DFN_",",3)=X
D FILE^DIE("","DGFDA","DGERR")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGRP1152A 10192 printed Oct 16, 2024@18:56:02 Page 2
DGRP1152A ;ALB/LEG - REGISTRATION SCREEN 11.5.2/VERIFICATION INFORMATION ;JUN 08, 2020@23:00
+1 ;;5.3;Registration;**1014**;AUG 13, 1993;Build 42
+2 ;=======================================================================================
EN(DFN) ;Main entry point to invoke the DGEN CCP DETAIL list
+1 ; Input -- DFN Patient IEN
+2 DO WAIT^DICD
+3 DO EN^VALM("DGEN CCP DETAIL")
+4 NEW VALMHDR,VALMBCK,VALMSG,VALMCNT
+5 QUIT
+6 ;
HDR ;Header code
+1 NEW DGDOB,DGPTYPE,DGSSNSTR,DGSSN
+2 NEW DGBLANKS,DGMEMID,DGNAME,DGPREFNM,DGPTYPE,DGTMP
+3 KILL VALMHDR
+4 SET DGDOB=$$GET1^DIQ(2,DFN,.03,"I")
+5 SET DGDOB=$$UP^XLFSTR($$FMTE^XLFDT($EXTRACT(DGDOB,1,12),1))
+6 SET DGSSNSTR=$$SSNNM^DGRPU(DFN)
+7 SET DGSSN=$PIECE($PIECE(DGSSNSTR,";",2)," ",3)
+8 SET DGPTYPE=$$GET1^DIQ(391,$$GET1^DIQ(2,DFN_",",391,"I")_",",.01)
+9 if DGPTYPE=""
SET DGPTYPE="PATIENT TYPE UNKNOWN"
+10 SET VALMHDR(1)=$PIECE(DGSSNSTR,";",1)_$SELECT($$GET1^DIQ(2,DFN,.2405)'="":" ("_$$GET1^DIQ(2,DFN,.2405)_")",1:"")_" "_DGDOB
+11 SET VALMHDR(2)=$SELECT($PIECE($PIECE(DGSSNSTR,";",2)," ",2)'="":$EXTRACT($PIECE($PIECE(DGSSNSTR,";",2)," ",2),1,40)_" ",1:"")_DGSSN_" "_DGPTYPE
+12 SET VALMHDR(3)=$JUSTIFY("",5)_"CCP Name"_$JUSTIFY("",20)_"Effective Date"
+13 QUIT
+14 ;
INIT ;Build patient Collateral screen
+1 DO CLEAN^VALM10
+2 DO CLEAR^VALM1
+3 DO TMP^DGRP1152U(.DGTMP)
+4 QUIT
+5 ;
EXIT ;Exit code
+1 DO CLEAN^VALM10
+2 DO CLEAR^VALM1
+3 KILL DGTMP,^TMP("VALM DATA",$JOB)
+4 QUIT
+5 ;
PEXIT ;DGEN CCP MENU protocol exit code
+1 ;Reset after page up or down
+2 SET VALMSG="+ Next Screen - Prev Screen ?? More Actions"
+3 QUIT
+4 ;
HELP ; Invoked from HELP CODE in List Template [DGEN CCP DETAIL]
+1 SET X="?"
DO DISP^XQORM1
+2 SET VALMSG="+ Next Screen - Prev Screen ?? More Actions"
+3 QUIT
+4 ;
ACT(DGACT) ; Entry point for menu action selection
+1 ; INPUT: DGACT = "A" - Add - DGEN CCP ADD protocol
+2 ; = "E" - Edit - DGEN CCP EDIT protocol
+3 ; = "R" - Remove - DGEN CCP REMOVE protocol
+4 NEW DGX,DA,DIE,DIC,DIK,DIPA,DR
+5 IF $GET(DGACT)=""
GOTO ACTQ
+6 ; DGRPV represents the "VIEW" or "EDIT" status that is created in routine DGRPV
+7 IF $GET(DGRPV)
DO FULL^VALM1
WRITE !,"View only. This action cannot be selected."
DO PAUSE^VALM1
GOTO ACTQ
+8 DO FULL^VALM1
+9 IF DGACT="A"
DO ADD
DO ACTQ
QUIT
+10 IF DGACT="E"
DO EDIT
DO ACTQ
QUIT
+11 IF DGACT="R"
DO REMOVE
DO ACTQ
QUIT
+12 QUIT
+13 ;
ACTQ ; menu action exit point
+1 SET VALMBCK="R"
+2 DO TMP^DGRP1152U(.DGTMP)
+3 QUIT
+4 ;
ADD ; Add new CCP to #1910 sub-file
+1 NEW DGCCPCD,DGEFFDT
+2 IF '$$ADASKCCP(.DGCCPCD)
QUIT
+3 IF '$$ADASKEFDT(DGCCPCD,.DGEFFDT)
QUIT
+4 NEW DIR,X,Y,DTOUT,DUOUT,DIROUT,DIRUT,DGCCPNM
+5 SET DGCCPNM=$$EXTERNAL^DILFD(2.191,1,"",DGCCPCD)
+6 SET DIR(0)="Y"
SET DIR("A")="Are you adding '"_DGCCPNM_"' as a new CCP"
SET DIR("B")="NO"
+7 DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)!$DATA(DIROUT)!'Y
QUIT
+8 ;saves new record
DO SAVREC(DFN,DGCCPCD,DGEFFDT)
+9 QUIT
+10 ;
EDIT ;EDIT EXISTING CCP
+1 NEW DGSEL,DGORIGIDX,DGORIGREC,DGCCPCD,DGEFFDT
+2 SET DGSEL=$$SELECT("E",.DGORIGIDX,.DGORIGREC)
if 'DGSEL
QUIT
+3 IF '$$EDASKCCP(DGORIGIDX,.DGCCPCD)
QUIT
+4 IF '$$EDASKEFDT(DGORIGIDX,DGORIGREC,DGCCPCD,.DGEFFDT)
QUIT
+5 ;saves new record
DO SAVREC(DFN,DGCCPCD,DGEFFDT)
+6 ; set END DATE into originally edited record
DO SAVENDT(DGORIGIDX)
+7 QUIT
+8 ;
REMOVE ;REMOVE EXISTING CCP
+1 NEW DGSEL,DGORIGIDX
+2 SET DGSEL=$$SELECT("R",.DGORIGIDX)
if 'DGSEL
QUIT
+3 NEW DIR,Y,DTOUT,DUOUT,DIROUT,DIRUT
+4 SET DIR(0)="Y"
SET DIR("A")="Are you sure you want to remove this CCP entry"
SET DIR("B")="NO"
+5 DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)!$DATA(DIROUT)!'Y
QUIT
+6 ; set END DATE into removed record
DO SAVENDT(DGORIGIDX)
+7 QUIT
+8 ;
SELECT(DGACT,DGORIGIDX,DGORIGREC) ;
+1 ; Input: DGACT - "E"dit or "R"emove
+2 ; Output: DGORIGIDX - (Pass by reference) The entry number of the selected CCP
+3 ; DGORIGREC - (Pass by reference) The fields of the selected CCP
+4 ; Returns the entry number selected
+5 ;
+6 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y,DGRECS,DGSEL
+7 SET DGRECS=$ORDER(DGTMP("IDX",""),-1)
+8 IF 'DGRECS
Begin DoDot:1
+9 WRITE !,"There are no entries to "_$SELECT(DGACT="E":"edit.",1:"remove.")
+10 DO PAUSE^VALM1
End DoDot:1
QUIT 0
+11 SET DIR(0)="NA^1:"_DGRECS_":0"
+12 SET DIR("A",1)=""
SET DIR("A")="Select Entry (1-"_DGRECS_"): "
DO ^DIR
KILL DIR
+13 SET DGSEL=Y
+14 IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT 0
+15 ; translate the display [num] to the ^DPT(DFN,5,IDX)
+16 SET DGORIGIDX=$ORDER(DGTMP("IDX",DGSEL,""))
SET DGORIGREC=^DPT(DFN,5,DGORIGIDX,0)
+17 QUIT DGSEL
+18 ;
ADASKCCP(DGCCPCD) ; Prompts for CCP to be ADDed
+1 ; Output: DGCCPCD - CCP Code to be added (Pass by Reference)
+2 ; Returns - TRUE if valid CCP entered
+3 ;
+4 NEW DIR,DTOUT,DUOUT,DGGOOD,Y,X
L1 ; Tag to call for re-prompting
+1 SET DIR(0)="2.191,1,A,O^^"
+2 SET DIR("A")="Add CCP: "
+3 DO ^DIR
+4 KILL DIR
+5 IF $DATA(DUOUT)!$DATA(DTOUT)
QUIT 0
+6 IF Y=""
QUIT 0
+7 SET DGCCPCD=Y
+8 DO CHKMULT1(DFN,DGCCPCD,.DGGOOD)
+9 IF 'DGGOOD
WRITE " ** Already have this CCP on file."
GOTO L1
+10 QUIT 1
+11 ;
EDASKCCP(DGORIGIDX,DGCCPCD) ; ASK EDIT CCP
+1 ; Input: DGORIGIDX - Entry number of the CCP selected for edit
+2 ; Output: DGCCPCD - The CCP Code that has been entered {Pass by Reference)
+3 ; Returns: TRUE is edit of the CCP was successful
+4 ;
+5 NEW DIR,DGENTRY,DTOUT,DUOUT,DGGOOD,X,Y
L2 ; Tag to call for re-prompting
+1 SET DIR("B")=$$GET1^DIQ(2.191,DGORIGIDX_","_DFN_",",1)
+2 SET DIR(0)="2.191,1,A,r^^"
+3 SET DIR("A")="CCP: "
+4 DO ^DIR
+5 KILL DIR
+6 IF $DATA(DUOUT)!$DATA(DTOUT)
QUIT 0
+7 SET DGCCPCD=Y
+8 DO CHKMULT1(DFN,DGCCPCD,.DGGOOD)
+9 IF 'DGGOOD
WRITE " ** Already have this CCP on file."
GOTO L2
+10 QUIT 1
+11 ;
ADASKEFDT(DGCCPCD,DGEFFDT) ; ASK ADD EFFECTIVE DATE AND IF VALID SAVE
+1 ; Input: DGCCPCD - CCP Code associated with the effective date
+2 ; Outut: DGEFFDT - Effective date entered for this CCP (Pass by Reference)
+3 ; Returns TRUE if valid effective date added for this CCP
+4 ;
+5 NEW DIR,DTOUT,DUOUT,Y,X,DGGOOD,DGEXDT,X,Y
+6 ; Sets DGEFFDT for the CCP to be added
+7 ;
L3 ; Tag to call for re-prompting
+1 SET DIR(0)="2.191,2,A^^"
+2 SET DIR("A")="Enter EFFECTIVE DATE: "
+3 SET DIR("B")="T"
+4 KILL X,Y
+5 DO ^DIR
+6 IF $DATA(DUOUT)!$DATA(DTOUT)
QUIT 0
+7 IF +Y<1
QUIT 0
+8 IF Y
IF $LENGTH(Y(0))=10
SET Y(0)=$PIECE(Y(0)," ")_" 0"_$PIECE(Y(0)," ",2)
+9 SET DGEFFDT=Y
SET DGEXDT=Y(0)
+10 IF '$LENGTH(DGEXDT)
if Y<0
WRITE " '"_X_"' is not a valid date."
GOTO L3
+11 DO CHKMULT2(DFN,DGCCPCD,DGEFFDT,.DGGOOD)
+12 IF 'DGGOOD
DO MULTERR^DGRP1152U
GOTO L3
+13 QUIT 1
+14 ;
EDASKEFDT(DGORIGIDX,DGORIGREC,DGCCPCD,DGEFFDT) ; ASK EFFECTIVE DATE AND IF VALID SAVE
+1 ; Input: DGORIGIDX - Entry number of the CCP selected for edit
+2 ; DGORIGREC - The fields of the selected CCP (0 node)
+3 ; DGCCPCD - CCP code for the associated Effective Date
+4 ; Input: DGEFFDT - Updated Effective Date (Pass by reference)
+5 ; Returns: TRUE is edit of Effective Date was successful
+6 ;
+7 NEW DIR,DTOUT,DUOUT,Y,X,DGGOOD,DGEXDT
L4 ; Tag to call for re-prompting
+1 SET DIR(0)="2.191,2,A,r^^"
+2 SET DIR("A")="Enter EFFECTIVE DATE: "
+3 SET DIR("B")=$$GET1^DIQ(2.191,DGORIGIDX_","_DFN_",",2)
+4 KILL X,Y
+5 DO ^DIR
+6 IF $DATA(DUOUT)!$DATA(DTOUT)
QUIT 0
+7 IF +Y<1
QUIT 0
+8 IF Y
IF $LENGTH(Y(0))=10
SET Y(0)=$PIECE(Y(0)," ")_" 0"_$PIECE(Y(0)," ",2)
+9 SET DGEFFDT=Y
SET DGEXDT=Y(0)
+10 IF '$LENGTH(DGEXDT)
if Y<0
WRITE " '"_X_"' is not a valid date."
GOTO L4
+11 ; If the edited CCP/Date matches the original CCP/Date quit - no changes
+12 IF (DGCCPCD_"^"_DGEFFDT)=$PIECE(DGORIGREC,U,2,3)
QUIT 0
+13 DO CHKMULT2(DFN,DGCCPCD,DGEFFDT,.DGGOOD)
+14 IF 'DGGOOD
DO MULTERR^DGRP1152U
GOTO L4
+15 QUIT 1
+16 ;
CHKMULT1(DFN,DGCCP,DGGOOD) ; checks for disallowed 'A' or 'I' multiples
+1 ; Input: DFN
+2 ; DGCCCP - The CPP code to check
+3 ; Output: DGGOOD - (Pass by Reference) - TRUE if OK
+4 ;
+5 NEW DGI,DGTIDX,DGTREC,DGTCCP,DGTENDT
+6 SET DGGOOD=1
+7 IF $LENGTH(DGCCP)'=1
QUIT
+8 ; checks for duplicate CCP if "ART/IVF" or "NEWBORN"
+9 IF "AI"[DGCCP
Begin DoDot:1
+10 SET DGTIDX=0
SET DGI=""
+11 FOR
SET DGI=$ORDER(DGTMP("IDX",DGI))
if 'DGI
QUIT
SET DGTIDX=$ORDER(DGTMP("IDX",DGI,""))
if 'DGTIDX
QUIT
IF DGI'=$GET(DGSEL)
SET DGTREC=$GET(DGTMP("IDX",DGI,DGTIDX))
if DGTREC=""
QUIT
Begin DoDot:2
+12 SET DGTCCP=$PIECE(DGTREC,U,2)
SET DGTENDT=$PIECE(DGTREC,U,4)
+13 IF DGTCCP=DGCCP
IF 'DGTENDT
SET DGGOOD=0
End DoDot:2
if 'DGGOOD
QUIT
End DoDot:1
QUIT
+14 QUIT
+15 ;
CHKMULT2(DFN,DGCCP,DGFMDT,DGGOOD) ; checks for disallowed same CCP with same EFFECTIVE DATE
+1 ; Input: DFN
+2 ; DGCCCP - The CPP code to check
+3 ; DGFMDT - Effective Date to check (Fileman format)
+4 ; Output: DGGOOD - (Pass by Reference) - TRUE if OK
+5 ;
+6 NEW DGTIDX,DGTCCP,DGTENDT,DGTREC
+7 SET DGGOOD=1
+8 IF $LENGTH(DGCCP)'=1
QUIT
+9 ; checks for duplicate date for same CCP
+10 IF "?CT"[DGCCP
IF DGFMDT
Begin DoDot:1
+11 SET DGTIDX=""
+12 FOR
SET DGTIDX=$ORDER(DGTMP("EFDT",DGFMDT,DGTIDX))
if 'DGTIDX
QUIT
Begin DoDot:2
+13 SET DGTREC=DGTMP("EFDT",DGFMDT,DGTIDX)
+14 SET DGTCCP=$PIECE(DGTREC,U,2)
+15 SET DGTENDT=$PIECE(DGTREC,U,4)
+16 IF DGTCCP=DGCCP
IF 'DGTENDT
SET DGGOOD=0
End DoDot:2
if 'DGGOOD
QUIT
End DoDot:1
+17 QUIT
+18 ;
SAVREC(DFN,DGCCPCD,DGEFFDT) ;save newly ADDed or EDITed record
+1 ;
+2 ; If this combination of Code and Effective date already exists in an End-Dated record, it will be reactivated
+3 IF $$SAVEXIST(DFN,DGCCPCD,DGEFFDT)
QUIT
+4 ; Otherwise, save a new record
+5 NEW %,Y,X,DGERR,DGIENS,DGFDA
+6 SET DGERR=0
+7 SET DGIENS=DFN_","
+8 SET DGIENS="+1,"_DGIENS
+9 DO NOW^%DTC
+10 SET DGFDA(2.191,DGIENS,.01)=%
+11 SET DGFDA(2.191,DGIENS,1)=DGCCPCD
+12 SET DGFDA(2.191,DGIENS,2)=DGEFFDT
+13 DO UPDATE^DIE("","DGFDA","","DGERR")
+14 IF DGERR
WRITE " **UNABLE TO SAVE**"
+15 QUIT
+16 ;
SAVEXIST(DFN,DGCCP,DGFMDT) ; Check for an existing CCP record to be saved
+1 ; Checks for a matching CCP/EFFECTIVE DATE record among the End Dated CCPs. If found, reuse it (Remove the end date)
+2 ; Inputs: DFN - Patient DFN
+3 ; DGCCP - CCP Code
+4 ; DGFMDT - CCP Effective date
+5 ; Returns: The Entry number of the reactivated CCP if found or NULL
+6 ;
+7 NEW DGTIDX,DGTCCP,DGTENDT,DGTREC,DGEXIST,DGERR,DGFDA
+8 IF $LENGTH(DGCCP)'=1!('DGFMDT)
QUIT ""
+9 ; For the effective date, check for a matching CCP - (the record should be end dated since there cannot be duplicate effective dates for an active CCP)
+10 SET (DGEXIST,DGTIDX)=""
+11 FOR
SET DGTIDX=$ORDER(DGTMP("EFDT",DGFMDT,DGTIDX))
if 'DGTIDX
QUIT
Begin DoDot:1
+12 SET DGTREC=DGTMP("EFDT",DGFMDT,DGTIDX)
+13 ; Don't check archived records
+14 IF $PIECE(DGTREC,U,5)
QUIT
+15 SET DGTCCP=$PIECE(DGTREC,U,2)
+16 SET DGTENDT=$PIECE(DGTREC,U,4)
+17 IF DGTCCP=DGCCP
IF DGTENDT'=""
Begin DoDot:2
+18 ; Matching record found
+19 SET DGEXIST=DGTIDX
+20 ; Set the LAST DATE UPDATED and Clear the End Date
+21 SET DGFDA(2.191,DGTIDX_","_DFN_",",.01)=$$NOW^XLFDT()
+22 SET DGFDA(2.191,DGTIDX_","_DFN_",",3)=""
+23 DO FILE^DIE("","DGFDA","DGERR")
End DoDot:2
End DoDot:1
if DGEXIST
QUIT
+24 QUIT DGEXIST
+25 ;
SAVENDT(DGSIDX) ;save END DATE in old rec
+1 ; Input: DGSIDX - Entry number of the CCP to set End Date
+2 ;
+3 NEW DGERR,DGFDA,X
+4 ; CCP LAST UPDATED DATE
+5 SET DGFDA(2.191,DGSIDX_","_DFN_",",.01)=$$NOW^XLFDT()
+6 ; END DATE
+7 DO NOW^%DTC
+8 SET DGFDA(2.191,DGSIDX_","_DFN_",",3)=X
+9 DO FILE^DIE("","DGFDA","DGERR")
+10 QUIT
