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

DGLOCK1.m

Go to the documentation of this file.
  1. DGLOCK1 ;ALB/MRL,JAM,ARF,JAM,ARF,JAM - PATIENT FILE DATA EDIT CHECK ; 28 JUL 86
  1. ;;5.3;Registration;**121,314,1014,1061,1075,1081,1082,1098,1109**;Aug 13, 1993;Build 13
  1. AOD ;AO Delete
  1. I $D(^DPT(DFN,.321)),$P(^(.321),U,2)="Y" W !?4,*7,"Can't delete as long as Agent Orange exposure is indicated." K X
  1. Q
  1. COMD ;Combat Delete
  1. I $D(^DPT(DFN,.52)),$P(^(.52),U,11)="Y" W !?4,*7,"Can't delete as long as Combat Service is indicated." K X
  1. Q
  1. INED ;Ineligible Delete
  1. I $D(^DPT(DFN,.15)),$P(^(.15),U,2)]"" W !?4,*7,"Can't delete this field as long as 'INELIGIBLE DATE' is on file." K X
  1. Q
  1. IRD ;ION Rad Delete
  1. I $D(^DPT(DFN,.321)),$P(^(.321),U,3)="Y" W !?4,*7,"Can't delete as long as Ionizing Radiation exposure is indicated." K X
  1. Q
  1. POWD ;POW Delete
  1. I $D(^DPT(DFN,.52)),$P(^(.52),U,5)="Y" W !?4,*7,"Still identified as former POW...Change status to delete." K X
  1. Q
  1. TADD ;Temp Add Delete
  1. I $D(^DPT(DFN,.121)),$P(^(.121),U,9)="Y" W !?4,*7,"Answer NO to the 'WANT TO ENTER TEMPORARY ADDRESS' prompt, then delete." K X
  1. Q
  1. VND ;Viet Svc Delete
  1. I $D(^DPT(DFN,.321)),$P(^(.321),U,1)="Y" W !?4,*7,"Can't delete as long as Vietnam Service is still indicated." K X
  1. Q
  1. SVDEL ;Panama, Grenada, Lebanon, Persian Gulf Svc Delete
  1. ;DGX = piece position of corresponding service indicated? field
  1. I $D(^DPT(DFN,.322)),$P(^(.322),U,DGX)="Y" W !?4,*7,"Can't delete as long as ",$S(DGX=1:"Lebanon",DGX=4:"Grenada",DGX=7:"Panama",1:"Persian Gulf")," is still indicated." K X
  1. K DGX
  1. Q
  1. EC S DGEC=$S('$D(^DPT(DFN,.36)):"",$D(^DIC(8,+$P(^DPT(DFN,.36),U,1),0)):$P(^(0),U,9),1:"") I DGEC=5 W !?4,*7,"Eligibility Code is 'NSC'...Can't be YES." K X,DGEC Q
  1. K DGEC Q
  1. HUDCK(DGEC) ; DG*5.3*1075; Check for when HUD-VASH eligibility code can be used
  1. ; Called by the Input Transform and SCREEN of ELIGIBILITY field (#.01) of the PATIENT ELIGIBILITIES subfile of PATIENT file (#2)
  1. ; Input:
  1. ; DGEC - (required) Eligibility Code
  1. ;
  1. ; Output:
  1. ; Function Value - Returns 1 if Eligibility Code can be used, 0 if Eligibility Code cannot be used
  1. ;
  1. ; HUD-VASH (MAS number 26) allowed after the date/time stored in parameter "DG PATCH*5.3*1075 ACTIVE"
  1. ; WORLD WAR II (MAS number 29) allowed only for Veterans that served during WW II (DG*5.3*1098)
  1. ;
  1. N DGACTIVE
  1. Q:$G(DGEC)="" 0
  1. I ($$NATCODE^DGENELA(DGEC))'=26,($$NATCODE^DGENELA(DGEC))'=29 Q 1
  1. ; Get the timestamp stored in the parameter
  1. I ($$NATCODE^DGENELA(DGEC))=26 D I $$NOW^XLFDT()<DGACTIVE Q 0
  1. . S DGACTIVE=$$GET^XPAR("PKG","DG PATCH DG*5.3*1075 ACTIVE",1)
  1. ; DG*5.3*1098 - Check if patient can have WORLD WAR II eligibility
  1. I $$NATCODE^DGENELA(DGEC)=29 I '$$WW2ELIG(DFN) Q 0
  1. Q 1
  1. WW2ELIG(DFN) ;DG*5.3*1098 - Determine if patient can have WORLD WAR II as a PATIENT ELIGIBILITIES
  1. ;
  1. ; INPUT: DFN = Patient IEN
  1. ; OUTPUT: 1 - Veteran is eligible for WW II eligibility
  1. ; 0 - Veteran is not eligible for WW II eligibility
  1. ;
  1. ; Selection criteria:
  1. ; a) patient is a Veteran
  1. ; b) patient has a Military Service Episode that includes any period from
  1. ; December 07, 1941 through December 31, 1946
  1. ; c) patient's birthdate is prior to January 01, 1933
  1. ;
  1. I '$$VET1^DGENPTA(DFN) Q 0 ;if a VETERAN continue else quit
  1. ;
  1. N DGBEGDT,DGENDDT,DGEPNUM,DGDATA,DGWWII
  1. ;check for an in range Military Service Episode (MSE) any period between
  1. ;December 07, 1941 and December 31, 1946, inclusive of these dates
  1. S (DGBEGDT,DGENDDT,DGDATA)="",(DGEPNUM,DGWWII)=0
  1. F S DGEPNUM=$O(^DPT(DFN,.3216,DGEPNUM)) Q:DGEPNUM="" D Q:DGWWII
  1. . S DGDATA=$G(^DPT(DFN,.3216,DGEPNUM,0))
  1. . S DGBEGDT=$P(DGDATA,U,1) ;set the begin date of the Veteran's MSE
  1. . S DGENDDT=$P(DGDATA,U,2) ;set the end date of the Veteran's MSE
  1. . I (DGBEGDT'>2461231),(DGENDDT'<2411207) S DGWWII=1 Q ;check the MSE for duration during World War II
  1. Q:'DGWWII 0 ;quit if no MSE match is found
  1. ;check if the Veteran's birthdate is prior to January 01, 1933
  1. I $$GET1^DIQ(2,DFN_",",.03,"I")'>2330101 Q 1 ;if Veteran's age is within range return a 1
  1. Q 0
  1. POS ;Screen
  1. K DGEC D SV1^DGLOCK I $D(X) S DIC("S")="I '$P(^(0),""^"",8),$D(^DPT(DA,.36)),$D(^DIC(21,+Y,""E"",+$P(^(.36),U,1)))" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X D:'$D(X) POSH I $D(X),$D(^DIC(21,X,0)),$P(^(0),U,7)]"" D POS1 Q
  1. Q
  1. POS1 S XX=$P(^DIC(21,X,0),U,7) I $P(^DPT(DA,0),U,3)]"" I $P(^(0),U,3)'>XX!($D(^XUSEC("DG ELIGIBILITY",DUZ))) K XX Q
  1. W !?5,*7,"Applicant is too young to have served in that period of service.",!?5,"See your supervisor if you require assistance." K X,XX Q
  1. POSH S DGEC=$S('$D(^DPT(DFN,.36)):"",$D(^DIC(8,+$P(^(.36),U,1),0)):$P(^(0),U,1),1:"") W !?5,"Current Eligibility Code" W:DGEC]"" ": ",DGEC I DGEC']"" W " is not defined. Must be defined in order",!?5,"to enter a POS."
  1. K DGEC Q
  1. SC S DGSCON=$S('$D(^DPT(DFN,.3)):0,$P(^(.3),U,1)="Y":1,1:0) I 'DGSCON W !?4,*7,"Not possible, applicant is not service-connected." K X,DGSCON Q
  1. K DGSCON Q
  1. ;
  1. ECD ;primary eligibility code input transform
  1. ;
  1. N DGNODE,DGPC,DGSER,DGVT,DGXX,DGCOV
  1. S DGVT=$G(^DPT(DFN,"VET")),DGSER=$S('$D(^DPT(DFN,.3)):0,$P(^(.3),U,1)="Y":1,1:0)
  1. I DGVT']"" K X W !?4,*7,"'VETERAN (Y/N)' prompt must be answered to select an Eligibility Code'" Q
  1. ; DG*5.3*1014 - Capture if COLLATERAL OF VET is the current Primary Eligibility
  1. S DGCOV=0 I $$GET1^DIQ(2,DFN_",",.361,"E")="COLLATERAL OF VET." S DGCOV=1
  1. ; DG*5.3*1061 Add eligibilities 24 and 25 to the screening logic
  1. ; DG*5.3*1075 Add the HUD-VASH eligibility code 26 to the codes for the screening logic for the PRIMARY ELIGIBILITY CODE prompt
  1. S DIC("S")="I $P(^DIC(8,+Y,0),U,5)=DGVT,'$P(^(0),U,7),$$NATCODE^DGENELA(+Y)'=24&($$NATCODE^DGENELA(+Y)'=25)&($$NATCODE^DGENELA(+Y)'=26)"
  1. ; DG*5.3*1081 - EXPANDED MH CARE NON-ENROLLEE cannot be Primary Elig Code if INELIGIBLE DATE (field .152) is set
  1. I $$GET1^DIQ(2,DFN,.152)'="" S DIC("S")=DIC("S")_",$$NATCODE^DGENELA(+Y)'=23"
  1. ; DG*5.3*1082 Add the PRESUMPTIVE PSYCHOSIS ELIGIBLE eligibility code 28 to the codes for the screening logic for the PRIMARY ELIGIBILITY CODE prompt
  1. S DIC("S")=DIC("S")_",$$NATCODE^DGENELA(+Y)'=28"
  1. ; DG*5.3*1098 Add the WORLD WAR II eligibility code 29 to the codes for the screening logic for the PRIMARY ELIGIBILITY CODE prompt
  1. S DIC("S")=DIC("S")_",$$NATCODE^DGENELA(+Y)'=29"
  1. ; DG*5.3*1109 Add the SERVICE ACT eligibility code 30 to the codes for the screening logic for the PRIMARY ELIGIBILITY CODE prompt
  1. S DIC("S")=DIC("S")_",$$NATCODE^DGENELA(+Y)'=30"
  1. I DGVT="N" G ECDS
  1. I DGSER S DGPC=$S(+$P(^DPT(DFN,.3),U,2)>49:1,1:0),DGXX=$S(DGPC:1,1:3),DIC("S")=DIC("S")_",($P(^(0),U,9)="_DGXX_")" G ECDS ;sc only
  1. I $P($G(^DPT(DFN,.52)),"^",5)="Y" S DIC("S")=DIC("S")_",($P(^(0),U,9)=18)" G ECDS ;pow only
  1. S DGXX="^1^3^18^" ; no sc<50, sc 50-100, pow
  1. I $P($G(^DPT(DFN,.53)),U)="Y" S DIC("S")=DIC("S")_",($P(^(0),U,9)=22)" G ECDS ;checks for PH Indicator
  1. S DGXX=DGXX_"22^" ;adds PH to DGXX string
  1. S DGNODE=$G(^DPT(DFN,.362))
  1. I $P(DGNODE,"^",12)'="Y" S DGXX=DGXX_"2^"
  1. I $P(DGNODE,"^",14)'="Y" S DGXX=DGXX_"4^"
  1. I $P(DGNODE,"^",13)'="Y" S DGXX=DGXX_"15^"
  1. F I=12:1:14 I $P(DGNODE,"^",I)="Y" S DGXX=DGXX_"5^"_$S(I'=14:"4^",1:"")
  1. I $P($G(^DPT(DFN,0)),"^",3)>2200101 S DGXX=DGXX_"16^17^" ; WWI or mexican border only
  1. S DIC("S")=DIC("S")_",("""_DGXX_"""'[(U_$P(^(0),U,9)_U))"
  1. ECDS D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
  1. ;
  1. ;catastrophic disability can not be primary
  1. I $G(X),$$NATNAME^DGENELA(X)="CATASTROPHICALLY DISABLED" K X Q
  1. ; DG*5.3*1061 Prevent eligibilities 24 and 25 from being primary eligibilities
  1. I $G(X),$$NATCODE^DGENELA(X)=24 K X Q
  1. I $G(X),$$NATCODE^DGENELA(X)=25 K X Q
  1. ; DG*5.3*1075 Prevent HUD-VASH eligibility code 26 from being a primary eligibility
  1. I $G(X),$$NATCODE^DGENELA(X)=26 K X Q
  1. ; DG*5.3*1082 Prevent PRESUMPTIVE PSYCHOSIS ELIGIBLE eligibility code 28 from being entered as a primary eligibility
  1. I $G(X),$$NATCODE^DGENELA(X)=28 K X Q
  1. ; DG*5.3*1098 Prevent WORLD WAR II eligibility code 29 from being entered as a primary eligibility
  1. I $G(X),$$NATCODE^DGENELA(X)=29 K X Q
  1. ; DG*5.3*1109 Prevent SERVCE ACT eligibility code 30 from being entered as a primary eligibility
  1. I $G(X),$$NATCODE^DGENELA(X)=30 K X Q
  1. ;
  1. ; DG*5.3*1014 - if editing Primary Eligibility "COLLATERAL OF VET", save off any CCPs
  1. I $G(X),DGCOV D REMOVE^DGRP1152U(DFN)
  1. Q