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