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

DGRP1152A.m

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