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

DGRPMS.m

Go to the documentation of this file.
  1. DGRPMS ;ALB/BRM,LBD,DJS,ARF - MILITARY SERVICE APIS ;11 Oct 2017 11:14am
  1. ;;5.3;Registration;**451,626,646,673,689,688,797,935,1044**;Aug 13, 1993;Build 13
  1. ;
  1. VALCON1(DFN,IEN,CDATE,FRTO) ; Valid conflict input for OIF/OEF/UNKNOWN OEF/OIF?
  1. ; Need to send the ien of the multiple as well as the DFN and
  1. ; determine the specific conflict area
  1. N Z
  1. S Z=$P("OIF^OEF^UNK",U,+$G(^DPT(DFN,.3215,+IEN,0)))
  1. ;Q:Z="UNK" 1 ; Never need to check this - only entered through HEC
  1. Q $$VALCON(DFN,Z_"-"_IEN,CDATE,FRTO)
  1. ;
  1. VALCON(DFN,CNFLCT,CDATE,FRTO,OEIFAIL) ;is this a valid conflict input?
  1. ;
  1. ;INPUT:
  1. ; FRTO - 0=FRDT 1=TODT (defaults to FRDT if FRTO="")
  1. ;OUTPUT:
  1. ; OEIFAIL = 1 for not within MSE for OIF/OEF data (pass by ref)
  1. ;
  1. N RTN,X,Y,FRDT,TODT,CNFLCTV,IGNORE,COMPOW,MSG,DTCHK,CNFLCT2,OEFOIF
  1. S OEIFAIL=0
  1. Q:'$D(DFN) "0^INVALID PATIENT"
  1. Q:'$D(^DPT(DFN)) "0^INVALID PATIENT"
  1. Q:'$$VALID^DGRPDT(.CDATE) "0^INVALID DATE"
  1. S FRTO=+$G(FRTO)
  1. I 'FRTO S TODT=$$GETDT(DFN,.CNFLCT),FRDT=CDATE K DGFRDT
  1. E S FRDT=$$GETDT(DFN,.CNFLCT,FRTO) S:$G(DGFRDT) FRDT=$G(DGFRDT) S TODT=CDATE K DGFRDT
  1. S DTCHK=$$DTUTIL^DGRPDT(CDATE,$$GETDT(DFN,.CNFLCT,'FRTO),1)
  1. I 'DTCHK D MSG($P(DTCHK,"^",2),2,2) Q DTCHK
  1. I CNFLCT="COMB"!(CNFLCT="POW") D
  1. .S COMPOW=$S(CNFLCT="COMB":1,1:2)
  1. .S CNFLCT2=CNFLCT
  1. .S CNFLCT=$$COMPOW($S($G(DGCOMLOC):$P(DGCOMLOC,"^"),1:$$GETDT(DFN,CNFLCT,3)))
  1. S CNFLCTV=""
  1. I CNFLCT]"" S CNFLCTV=$$CNFLCTDT^DGRPDT(FRDT,$S(FRTO:TODT,1:""),.CNFLCT)
  1. I ('CNFLCTV) D MSG($P(CNFLCTV,"^",2),2,1) Q CNFLCTV ;dates are not within conflict
  1. ;
  1. S MSG=$S('$G(COMPOW):"Conflict",$G(COMPOW)=2:"POW",1:"Combat")
  1. I FRDT,TODT,'$$B4^DGRPDT(FRDT,TODT,0) D MSG((MSG_" From Date is not Before "_MSG_" To Date"),2,1) Q "0^"_MSG_" From Date is not Before "_MSG_" To Date"
  1. S IGNORE=$S('$P(CNFLCT,"-",2):$P($P($T(@($P(CNFLCT,"-"))),";;",2),"^",FRTO+1),1:"")
  1. S:$G(COMPOW) IGNORE=$P($P($T(@(CNFLCT2)),";;",2),"^",FRTO+1)
  1. ;
  1. ; Check for overlaps and dates w/in MSE's, except for POW DG*5.3*688
  1. S RTN=1
  1. I $G(COMPOW)'=2 D
  1. . S OEFOIF=$S($P(CNFLCT,"-",2):$P(CNFLCT,"-",2)_U_CNFLCT,1:""),RTN=$$COVRLP2^DGRPDT(DFN,FRDT,TODT,IGNORE,.OEFOIF)
  1. . I 'RTN,$G(OEFOIF),$G(OEFOIF(1)) S OEIFAIL=1
  1. Q:RTN RTN
  1. D MSG($P(RTN,"^",2),2,1)
  1. Q RTN
  1. ;
  1. VALMSE(DFN,MDATE,FRTO,FLD) ;is this a valid Military Service Episode date?
  1. ;
  1. ;INPUT:
  1. ; FRTO - 0=FRDT 1=TODT (defaults to FRDT if FRTO="")
  1. ; FLD - MSE field being edited/added (MSL,MSNTL,MSNNTL)
  1. ; "MSE-"_IEN of MSE in sub-file #2.3216 (DG*5.3*797)
  1. ;
  1. N DTCHK,DUPCHK,FDDFLAG,FRDT,IGNORE,RTN,TODT,X,Y
  1. ; DGCOMBR - branch of service, from input transforms
  1. ; FDDFLAG - boolean for FDD overlap
  1. Q:'$D(DFN) "0^INVALID PATIENT"
  1. Q:'$D(^DPT(DFN)) "0^INVALID PATIENT"
  1. Q:'$$VALID^DGRPDT(.MDATE) "0^INVALID DATE"
  1. ; DJS, Check for Future Discharge Date overlap; DG*5.3*935
  1. S (FDDFLAG,X)=0 F S X=$O(^DPT(DFN,.3216,X)) Q:'X!FDDFLAG S Y=$G(^(X,0)) I $P(Y,U,8),'(MDATE>$P(Y,U,8))&'(MDATE<$P(Y,U)) S FDDFLAG=1
  1. I FDDFLAG D Q "0^FDD date overlap"
  1. . D MSG("Date overlaps with a record that has a Future Discharge Date.",2,1)
  1. ;
  1. S FRTO=+$G(FRTO)
  1. I 'FRTO S FRDT=MDATE,TODT=$$GETDT(DFN,.FLD,FRTO) K DGFRDT
  1. E S FRDT=$$GETDT(DFN,.FLD,FRTO) S:$G(DGFRDT) FRDT=$G(DGFRDT) S TODT=MDATE K DGFRDT
  1. S DTCHK=$$DTUTIL^DGRPDT(MDATE,$$GETDT(DFN,.FLD,'FRTO),1)
  1. I 'DTCHK D MSG($P(DTCHK,"^",2),2,2) K DGCOMBR Q DTCHK
  1. ;Check for duplicate Service Entry Date
  1. I 'FRTO,FRDT S DUPCHK=$$DUPCHK(DFN,.FRDT,.FLD) I 'DUPCHK D MSG($P(DUPCHK,"^",2),2,2) Q DUPCHK
  1. I FRTO,FRDT,TODT,'$$B4^DGRPDT(.FRDT,.TODT,0) D MSG("Service Entry Date is not before Service Separation Date",2,1) K DGCOMBR Q "0^Service Entry Date is not before Service Separation Date"
  1. S IGNORE=$P($P($T(@($P(FLD,"-"))),";;",2),"^",FRTO+1)
  1. S RTN=$$OVRLPCHK^DGRPDT(.DFN,.FRDT,.TODT,1,.IGNORE,,$P(FLD,"MSE-",2))
  1. I $G(DGCOMBR)']"" S DGCOMBR=$$GETDT(DFN,.FLD,4)
  1. I RTN,FRTO,$$BRANCH(.DGCOMBR),('$$WWII(DFN,TODT,.FLD)) D MSG("Branch of Service Requires WWII Dates of Service",2,1) K DGCOMBR Q "0^BOS Requires WWII Dates"
  1. K DGCOMBR
  1. Q:RTN RTN
  1. D MSG($P(RTN,"^",2),2,1)
  1. Q RTN
  1. ;
  1. BRANCH(DGCOMBR) ;branches of service that require WWII service dates
  1. N BRANCH
  1. Q:'$G(DGCOMBR) 0
  1. S BRANCH=$P(DGCOMBR,"^",2)
  1. Q:BRANCH="MERCHANT SEAMAN" 1
  1. Q:BRANCH="F.COMMONWEALTH" 1
  1. Q:BRANCH="F.GUERILLA" 1
  1. Q:BRANCH="F.SCOUTS NEW" 1
  1. Q:BRANCH="F.SCOUTS OLD" 1
  1. Q 0
  1. ;
  1. VALCOMP(DFN,CODE,DGEPI) ; Verify component is consistent with the corresponding
  1. ; branch of service Also, branch of service must be entered before
  1. ; component.
  1. ; ACTIVATED NATIONAL GUARD (G) only valid for ARMY or AIR FORCE or SPACE FORCE branch
  1. ; ACTIVATED RESERVE (V) only valid for ARMY, AIR FORCE, SPACE FORCE MARINES, NAVY
  1. ; or COAST GUARD branch
  1. ; DFN = ien of patient in file 2
  1. ; DGEPI = episode # to check (1=LAST, 2=NTL, 3=NNTL)
  1. ; CODE = the component code
  1. ; OUTPUT: 1 if valid component
  1. ; 0 if invalid component or branch of serv missing
  1. N Z
  1. ;Get BOS from MSE multiple .3216 if DGEPI contains "MSE" (DG*5.3*797)
  1. I $G(DGEPI)["MSE" S Z=+$P($G(^DPT(DFN,.3216,+DGEPI,0)),U,3)
  1. E S Z=+$P($G(^DPT(DFN,.32)),U,DGEPI*5)
  1. I 'Z Q 0 ; Require bos
  1. I CODE="R" Q 1 ; Regular is valid for all
  1. ;DG*5.3*1044-SPACE FORCE #15 added to next line of code
  1. Q:(Z=1)!(Z=2)!(Z=15) 1 ; Army (1)/air force (2)/space force (15) valid for guard and reserves
  1. ; reserves also include navy (3), marines (4), coast guard (5)
  1. I CODE="V" Q $S(Z>2&(Z<6):1,1:0)
  1. ;
  1. Q 0
  1. ;
  1. GETDT(DFN,CNFLCT,FRTO) ; get from date, to date, or location from patient file
  1. ;
  1. N CFLDS,CFLD,CNF1,CNF2,RTN1,IENS,FILE
  1. Q:'$D(DFN) ""
  1. Q:'$D(^DPT(DFN)) ""
  1. Q:$G(CNFLCT)="" ""
  1. S:$G(FRTO)="" FRTO=0
  1. S CNF1=$P(CNFLCT,"-"),CNF2=+$P(CNFLCT,"-",2)
  1. ; OEF/OIF/ UNKNOWN OEF/OIF data without a supplied entry in the
  1. ; multiple cannot be retrieved OEF-1 indicates an OEF location
  1. ; stored at the '1' subscript of the .3215 multiple
  1. I "^OEF^OIF^UNK^"[(U_CNF1_U),'CNF2 Q ""
  1. ; MSE data retrieved from .3216 multiple (DG*5.3*797)
  1. I CNF1="MSE",'CNF2 Q ""
  1. S CFLDS=$P($T(@(CNF1)),";;",2) Q:CFLDS']"" ""
  1. S CFLD=$S('FRTO:$P(CFLDS,"^",2),FRTO=1:$P(CFLDS,"^"),1:$P(CFLDS,"^",3))
  1. Q:'CFLD ""
  1. S IENS=DFN_",",FILE=2
  1. ; For MSE set ref to sub-file 2.3216 (DG*5.3*797)
  1. ; For OIF/OEF set ref to sub-file 2.3215
  1. S:CNF2 IENS=CNF2_","_IENS,FILE=$S(CNF1="MSE":2.3216,1:2.3215)
  1. S RTN1=$$GET1^DIQ(FILE,IENS,CFLD,"I")
  1. I FRTO=4 S RTN1=RTN1_"^"_$$EXTERNAL^DILFD(FILE,CFLD,"",RTN1)
  1. Q RTN1
  1. ;
  1. WWII(DFN,TODT,FLD) ; was this patient in WWII?
  1. ; this API assumes the WWII period to be from 12/07/41-12/31/46
  1. ;
  1. N OK,NODE,DATA,WWIIS,WWIIE,PATDT,PATE,PATS
  1. Q:'$G(DFN) "-1^UNKNOWN"
  1. ; Use MSE data from sub-file #2.3216 (DG*5.3*797)
  1. I $G(FLD)["MSE" S NODE(2.3216)=".01,.02"
  1. E S NODE(.32)=".326,.327,.3285,.3292,.3293,.32945,.3297,.3298"
  1. S WWIIS=2411207,WWIIE=2461231
  1. D GETDAT^DGRPDT(DFN,.NODE,.DATA)
  1. S PATDT=$G(FLD) Q:PATDT']"" 0
  1. S PATS=$P($G(DATA(PATDT)),"^"),PATE=$P($G(DATA(PATDT)),"^",2)
  1. S:'$G(TODT) TODT=PATE
  1. S OK=0
  1. S OK=$$WITHIN^DGRPDT(WWIIS,WWIIE,PATS)
  1. S:'OK OK=$$WITHIN^DGRPDT(WWIIS,WWIIE,TODT)
  1. S:'OK OK=$$RWITHIN^DGRPDT(PATS,TODT,WWIIS,WWIIE)
  1. Q $G(OK)
  1. DELMSE(DFN,TYPE) ; delete MSE from patient
  1. ;
  1. ; Input: DFN - Internal entry number for the Patient File (#2)
  1. ; TYPE - 1=Last MSE 2=Next to Last MSE 3=Next to Next to Last
  1. ;
  1. Q:'$G(TYPE)
  1. Q:(('$G(DFN))!'$D(^DPT(DFN)))
  1. N IENS,FDA,X,X1,X2,Y,ZZ,ROOT
  1. S IENS=DFN_",",ROOT="FDA(2,IENS)",X=""
  1. I TYPE=1 F ZZ=.324,.326,.327,.328 S @ROOT@(ZZ)=X
  1. I TYPE=2 F ZZ=.329,.3292,.3293,.3294 S @ROOT@(ZZ)=X
  1. I TYPE=3 F ZZ=.3295,.3297,.3298,.3299 S @ROOT@(ZZ)=X
  1. D FILE^DIE("K","FDA","ERR")
  1. Q
  1. ;
  1. COMPOW(VAL) ;convert POW and Combat Location fields
  1. ;
  1. N ABRV
  1. Q:'$G(VAL) ""
  1. S ABRV=$$GET1^DIQ(22,VAL_",",1,"I")
  1. Q:ABRV="WWI" "WWI"
  1. Q:ABRV="WWII-EUROPE" "WWIIE"
  1. Q:ABRV="WWII-PACIFIC" "WWIIP"
  1. Q:ABRV="KOREAN" "KOR"
  1. Q:ABRV="VIETNAM" "VIET"
  1. Q:ABRV="OTHER" "OTHER"
  1. Q:ABRV="PERSIAN GULF" "GULF"
  1. Q:ABRV="YUGOSLAVIA" "YUG"
  1. Q:ABRV="SOMALIA" "SOM"
  1. Q ""
  1. ;
  1. FV(X) ;Is this a Filipino Vet branch of service?
  1. ;Added for HVE II (DG*5.3*451)
  1. ;INPUT: X = IEN Branch of Service file #23
  1. ;OUTPUT: 1 = Filipino Vet BOS (F.COMMONWEALTH, F.GUERILLA, F.SCOUTS NEW)
  1. ; 2 = Filipino Vet BOS (F.SCOUTS OLD)
  1. ; 0 = Not Filipino Vet BOS
  1. N FV
  1. I '$G(X) Q 0
  1. S FV=$P($G(^DIC(23,X,0)),U,1)
  1. Q $S(FV="F.SCOUTS OLD":2,$E(FV,1,2)="F.":1,1:0)
  1. ;
  1. FVP ;MUMPS cross-reference "AFV1" on Service Branch [Last] (#.325), "AFV2"
  1. ;on Service Branch [NTL] (#.3291), and "AFV3" on Service Branch [NNTL]
  1. ;(#.3296) in the Patient file #2. If the Service Branch fields do not
  1. ;contain a Filipino Veteran branch of service, the Filipino Vet Proof
  1. ;field (#.3214) will be deleted.
  1. Q:'$G(DA)
  1. N BOS,MS,FV,IENS,FDA
  1. S MS=$G(^DPT(DA,.32))
  1. F BOS=5,10,15 S FV=$$FV($P(MS,U,BOS)) Q:FV=1
  1. I FV=1 Q ;Filipino Vet BOS found, quit
  1. ;Delete Filipino Vet Proof
  1. S IENS=DA_",",FDA(2,IENS,.3214)="@"
  1. D FILE^DIE("","FDA")
  1. Q
  1. ;
  1. FVP1 ;MUMPS cross-reference "AFV3216" on the Service Branch field (#.03)
  1. ;in the Military Service Episode sub-file (#2.3216) of the Patient
  1. ;file (#2). If none of the Service Branch fields in the multiple
  1. ;contain a Filipino Veteran branch of service, the Filipino Vet Proof
  1. ;field (#.3214) will be deleted.
  1. ;Added for DG*5.3*797
  1. Q:'$G(DA(1))
  1. N BOS,MS,FV,IENS,FDA
  1. S (FV,MS)=0
  1. F S MS=$O(^DPT(DA(1),.3216,MS)) Q:'MS!(FV=1) D
  1. .I $G(DA)=MS Q
  1. .S BOS=$P($G(^DPT(DA(1),.3216,MS,0)),U,3)
  1. .S FV=$$FV(BOS)
  1. I FV=1 Q ;Filipino Vet BOS found, quit
  1. ;Delete Filipino Vet Proof
  1. S IENS=DA(1)_",",FDA(2,IENS,.3214)="@"
  1. D FILE^DIE("","FDA")
  1. Q
  1. ;
  1. DUPCHK(DFN,FRDT,FLD) ; Check for duplicate Service Entry Date
  1. ;INPUT: DFN = Patient file IEN
  1. ; FRDT = Service Entry Date being checked
  1. ; FLD = "MSE-"_IEN of 2.3216 sub-file record
  1. ;OUTPUT: DUP = Error message if duplicate found
  1. ; 1 = No duplicate found
  1. N MSEIEN,IEN,MSE,DUP
  1. I '$G(DFN) Q 1
  1. I '$G(FRDT) Q 1
  1. S MSEIEN=$P($G(FLD),"MSE-",2) I 'MSEIEN Q 1
  1. ; Get MSE data
  1. D GETMSE^DGMSEUTL(DFN,.MSE) I '$D(MSE) Q 1
  1. S IEN=0 F S IEN=$O(MSE(IEN)) Q:'IEN D
  1. .I FRDT=$P(MSE(IEN),"^"),'$D(MSE(IEN,MSEIEN)) S DUP="0^Duplicate Service Entry Date not allowed"
  1. I $D(DUP) Q DUP
  1. Q 1
  1. ;
  1. MSG(MSGTXT,LF1,LF2) ; This api will format the output text in order to utilize
  1. ; the EN^DDIOL utility.
  1. ;INPUT: MSGTXT = Message text to display
  1. ; LF1 = Number of line feeds to preceed the message
  1. ; L2F = Number of line feeds to follow the message
  1. ;
  1. N MSGARY,LFSTR
  1. S $P(LFSTR,"!",50)="!"
  1. S:$G(LF1)'="" MSGARY(.5,"F")=$E(LFSTR,1,(LF1-1))
  1. S MSGARY(1)=MSGTXT
  1. S:$G(LF2)'="" MSGARY(2,"F")=$E(LFSTR,1,LF2)
  1. D EN^DDIOL(.MSGARY)
  1. Q
  1. ;
  1. CNFLCT ;; *** DO NOT REMOVE BELOW CONFLICT FIELD LOCATIONS ***
  1. ;; FROM DATE^TO DATE
  1. WWI ;;
  1. WWIIE ;;
  1. WWIIP ;;
  1. KOR ;;
  1. VIET ;;.32104^.32105
  1. LEB ;;.3222^.3223
  1. GREN ;;.3225^.3226
  1. PAN ;;.3228^.3229
  1. GULF ;;.322011^.322012
  1. SOM ;;.322017^.322018
  1. YUG ;;.32202^.322021
  1. OEF ;;.02^.03
  1. OIF ;;.02^.03
  1. UNK ;;.02^.03
  1. ;;
  1. ;; **BELOW VALUES ARE USED FOR MSE CHECKS - DO NOT REMOVE ***
  1. ;; ENTRY DATE^SEPARATION DATE
  1. MSE ;;.01^.02^.03
  1. MSL ;;.326^.327^.325
  1. MSNTL ;;.3292^.3293^.3291
  1. MSNNTL ;;.3297^.3298^.3296
  1. ;;
  1. ;; **BELOW VALUES ARE USED FOR POW AND COMBAT CHECKS - DO NOT REMOVE
  1. ;; FROM DATE^TO DATE^LOCATION
  1. COMB ;;.5293^.5294^.5292
  1. POW ;;.527^.528^.526
  1. ;;