DGRP61 ;ALB/PJH,LBD,DJS,JAM,JAM,ARF - Patient MSDS History - List Manager Screen ;16 Oct 2017 16:04:16
;;5.3;Registration;**797,909,935,947,966,1014,1044**;Aug 13,1993;Build 13
;
EN(DFN) ;Main entry point to invoke the DGEN MSDS PATIENT list
; Input -- DFN Patient IEN
;
D WAIT^DICD
D EN^VALM("DGEN MSDS PATIENT")
Q
;
HDR ;Header code
N X
S VALMHDR(1)=$J("",25)_"MILITARY SERVICE DATA, SCREEN <6.1>"
D LISTHDR^DGRPU(2) ;DG*5.3*1014 - ARF - sets patient data in the 2nd and 3rd entries in VALMHDR array
;D PID^VADPT ;DG*5.3*1014 begin comment previous code
;S VALMHDR(2)=$E("Patient: "_$P($G(^DPT(DFN,0)),U),1,30)
;S VALMHDR(2)=VALMHDR(2)_" ("_VA("BID")_")"
;S X="PATIENT TYPE UNKNOWN"
;I $D(^DPT(DFN,"TYPE")),$D(^DG(391,+^("TYPE"),0)) S X=$P(^(0),U,1)
;S VALMHDR(2)=$$SETSTR^VALM1(X,VALMHDR(2),60,80)
;S VALMHDR(3)=$J("",4)_"Service Branch/Component Service #"
;S VALMHDR(3)=VALMHDR(3)_" Entered Separated Discharge" ;DG*5.3*1014 end comment previous code
S VALMHDR(4)=$J("",4)_"Service Branch/Component Service #"
S VALMHDR(4)=VALMHDR(4)_" Entered Separated Discharge"
Q
;
INIT ;Build patient MSDS screen
D CLEAN^VALM10
K ^TMP("DGRP61",$J),DGSEL
;
N GLBL
S GLBL=$NA(^TMP("DGRP61",$J))
D GETMSE(DFN,GLBL,1)
;Check if any old MSEs didn't copy and display warning message
I $$WARNMSG^DGMSEUTL(DFN) D
.S VALMSG="**More MSEs available to view on History Screen**"
.D MSG^VALM10(VALMSG)
Q
;
GETMSE(DFN,GLBL,NUM) ;Load service episodes from .3216 array
; INPUT: DFN = Patient IEN
; GLBL = ^TMP global ref
; NUM = 1 - display line numbers
N DGDATA,DGDATE,DGSUB,X1,X2,X
; DGSEL - selectable items, DGSEL("episode count") - episode count for DGSEL
; not all items may be selectable
K DGSEL S VALMCNT=0,DGDATE="",DGSEL("episode count")=0
F S DGDATE=$O(^DPT(DFN,.3216,"B",DGDATE),-1) Q:'DGDATE D
. S DGSUB=$O(^DPT(DFN,.3216,"B",DGDATE,"")) Q:'DGSUB
. S DGDATA=$G(^DPT(DFN,.3216,DGSUB,0)) Q:DGDATA=""
. D EPISODE(DGDATA,GLBL,NUM)
Q
;
EPISODE(DGDATA,GLBL,NUM) ;Format individual service episode
N DGFDD,DGRPSB,DGRPSC,DGRPSD,DGRPSE,DGRPSN,DGRPSS,Z
; increment episode count
S DGSEL("episode count")=DGSEL("episode count")+1
S DGRPSB=+$P(DGDATA,U,3),DGRPSC=$P(DGDATA,U,4),DGRPSN=$P(DGDATA,U,5)
;Service Branch/Component
S Z=$S($D(^DIC(23,DGRPSB,0)):$E($P(^(0),"^",1),1,15),1:"UNKNOWN")
I DGRPSC'="" D
. N Z0
. S Z0=$$SVCCOMP^DGRP6CL(DGRPSC) Q:Z0=""
. S Z=Z_"/"_Z0
;Filipino vet proof
I $$FV^DGRPMS(DGRPSB)=1 S Z=$E(Z_$J("",21),1,21)_"("_$P($G(^DPT(DFN,.321)),U,14)_")"
;Service Number
S Z=Z_$J("",26-$L(Z))_$S(DGRPSN]"":DGRPSN,1:"UNKNOWN")
S Z=Z_$J("",42-$L(Z))
;Entry and separation dates
S DGRPSE=$P(DGDATA,U,1),DGRPSS=$P(DGDATA,U,2)
S X=$S(DGRPSE]"":$$FMTE^XLFDT(DGRPSE,"5DZ"),1:"UNKNOWN ")
S Z=Z_$E(X,1,10)_" "
S X=$S(DGRPSS]"":$$FMTE^XLFDT(DGRPSS,"5DZ"),1:"UNKNOWN ")
S Z=Z_$E(X,1,10)_" "
;DJS, Add FUTURE DISCHARGE DATE; DG*5.3*935
;DGFDD = FUTURE DISCHARGE DATE (internal)
;DGFDD("DISP") = FUTURE DISCHARGE DATE (display)
S DGFDD=$P(DGDATA,U,8),DGFDD("DISP")=$S(DGFDD]"":$$FMTE^XLFDT(DGFDD,"5DZ"),1:"")
;Discharge type
S DGRPSD=+$P(DGDATA,U,6)
I 'DGRPSD S Z=Z_"UNKNOWN"
E S Z=Z_$S($D(^DIC(25,+DGRPSD)):$E($P(^DIC(25,DGRPSD,0),"^",1),1,9),1:"UNKNOWN")
;
S VALMCNT=VALMCNT+1
; Add line numbers if NUM true
I $G(NUM) D
. ;DJS, Indicate MSE episode with FDD not editable or deletable; DG*5.3*935
. ; not selectable, put < > around number, stop
. I $G(DGRPV)!($P(DGDATA,U,7)]"")!($P(DGDATA,U,8)]"") S Z="<"_DGSEL("episode count")_"> "_Z Q
. ; item is selectable, put into DGSEL, [ ] around number
. S Z="["_DGSEL("episode count")_"] "_Z,DGSEL(DGSEL("episode count"))=DGRPSE
;
; Save to List Manager array for display
S @GLBL@(VALMCNT,0)=$S($G(NUM):Z,1:$J("",4)_Z)
; JAM; DG*5.3*947 - Track the array entries that are MSE data in the "1" subscript
S @GLBL@(VALMCNT,1)=""
; JAM; DG*5.3*947 - if Reason for Early Separation is present, include it in output
; JAM; DG*5.3*966 - If patient record has Separation Reason Code (piece 10), retrieve the Description from file #24
; otherwise get description from piece 9
N RESDESC
I $P(DGDATA,U,10)]"" D
. S RESDESC=$$GET1^DIQ(26,$P(DGDATA,U,10),.02)
E S RESDESC=$P(DGDATA,U,9)
I RESDESC]"" D
. ;use the DIWP api to format the text which can be longer than 80 chars
. N X,I,DIWL,DIWR,DIWF,RESLINE
. K ^UTILITY($J,"W")
. S X="Early Separation Reason: "_RESDESC,DIWL=0,DIWR=80,DIWF=""
. D ^DIWP
. M RESDESC=^UTILITY($J,"W",0)
. F I=1:1:RESDESC D
. . S RESLINE=RESDESC(I,0)
. . S VALMCNT=VALMCNT+1,@GLBL@(VALMCNT,0)=RESLINE
; end patch DG*5.3*947 changes
;
D:DGFDD ; if FDD found, add to display
. S VALMCNT=VALMCNT+1,@GLBL@(VALMCNT,0)=" Future Discharge Date: "_DGFDD("DISP")
Q
;
HELP ;Help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ;Exit code
D CLEAN^VALM10
D CLEAR^VALM1
K ^TMP("DGRP61",$J)
Q
;
PEXIT ;DGEN MSDS MENU protocol exit code
S VALMSG="+ Next Screen - Prev Screen ?? More Actions"
;Reset after page up or down
;D XQORM
Q
;
ACT(DGACT) ; Entry point for menu action selection
; INPUT: DGACT = "A" - Add - DGEN MSDS ADD protocol
; = "E" - Edit - DGEN MSDS EDIT protocol
; = "D" - Delete - DGEN MSDS DELETE protocol
N DGX,DA,DIE,DIC,DIK,DIPA,DR,X,Y
I $G(DGACT)="" G ACTQ
I $G(DGRPV) W !,"View only. This action cannot be selected." D PAUSE^VALM1 G ACTQ
D FULL^VALM1
I DGACT="A" D ADD G ACTQ
I '$O(DGSEL(0)) D G ACTQ
. W !,"There are no episodes to "_$S(DGACT="E":"edit.",1:"delete.")
. I $G(VALMCNT) D HECHLP
. D PAUSE^VALM1
S DGX=$$SEL(DGACT) I 'DGX G ACTQ
S DGX=$G(DGSEL(DGX)) I 'DGX G ACTQ
S DA(1)=DFN,DIC="^DPT("_DA(1)_",.3216,",DIC(0)="BX",X=DGX
D ^DIC I Y<0 W !,"This episode is not in the patient's record." D PAUSE^VALM1 G ACTQ
S DIPA("DA")=+Y
I DGACT="E" K DA,DIC,DGFRDT S DIE="^DPT(",DA=DFN D SETDR1 D ^DIE G ACTQ
; deletion, ask user first
I DGACT="D",$$RUSURE S DIK=DIC,DA(1)=DFN,DA=DIPA("DA") D ^DIK K DA,DIK
;
; DG*5.3*909 Potentially change Camp Lejeune to No with MSE changes
ACTQ ; menu action exit point
D INIT S VALMBCK="R" D SETCLNO^DGENCLEA Q
;
ADD ; Add new MSE to #2.3216 sub-file
N X,Y,DIK,DA,DR,DIE,NEXT,DGFRDT
; Get next record number in sub-file
S NEXT=$O(^DPT(DFN,.3216,"A"),-1),NEXT=NEXT+1
D ZNODE(1)
; Prompt for MSE fields
S DIE="^DPT("_DFN_",.3216,",DA(1)=DFN,DA=NEXT D SETDR2 D ^DIE
I X["BAD" S DIK="^DPT("_DFN_",.3216,",DA(1)=DFN,DA=NEXT D ^DIK
; Check if new record is missing or incomplete
I '$D(^DPT(DFN,.3216,NEXT)) D ZNODE(-1) Q
I '$P(^DPT(DFN,.3216,NEXT,0),U) D Q
.S DIK="^DPT("_DFN_",.3216,",DA(1)=DFN,DA=NEXT D ^DIK D ZNODE(-1)
;
; File FILIPINO VET PROOF, if set
I $G(DIPA("FVP"))]"" D
.K DA,DR S DIE="^DPT(",DA=DFN,DR=".3214///^S X=DIPA(""FVP"")"
.D ^DIE
Q
;
SEL(ACT) ; function, prompt for episode to edit/delete
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
; range is 1 to episode count, must be in DGSEL to be selectable
S DIR(0)="NAO^1:"_DGSEL("episode count")_"^K:'$D(DGSEL(X)) X"
S DIR("A")="Select Episode: "
S DIR("?")="^D SELHLP^DGRP61(ACT)"
D ^DIR I 'Y Q 0
Q Y
;
SELHLP(ACT) ; Help message for episode prompt
W !,"Select an episode to ",$S(ACT="E":"edit.",1:"delete.")
W !,"Only numbers in square brackets [ ] are selectable."
D HECHLP
N DIR D PAUSE^VALM1
Q
HECHLP ; Help message for episodes that can only be changed by HEC
W !,"Angled brackets < > indicate episodes that cannot be changed in VistA."
W !,"Please contact the HECAlert mail group or the HEC if you need to update"
W !,"this information."
Q
;
ZNODE(VAL) ; Update zero node of MSE multiple .3216
Q:'$G(VAL) Q:'$G(DFN)
N ZNODE
S ZNODE=$G(^DPT(DFN,.3216,0))
S ^DPT(DFN,.3216,0)="^2.3216D^"_($P(ZNODE,U,3)+VAL)_U_($P(ZNODE,U,4)+VAL)
Q
SETDR1 ; Set DR array to edit MSE fields
S DR="I '$G(DIPA(""DA"")) S Y=0;.3216////^S X=""`""_DIPA(""DA"");.3214///^S X=$G(DIPA(""FVP""))"
S DR(2,2.3216)="D SET0^DGRP61(.DA,.DIPA);@61;.03;S DIPA(""X"")=X;I X'="""" S:$$FV^DGRPMS(X)'=1 Y=""@62"";S DIPA(""FVP"")=$$FVP^DGRP61"
S DR(2,2.3216,1)="I DIPA(""FVP"")=""^"" K DIPA(""FVP"") S Y=0;I DIPA(""FVP"")="""" D PRF^DGRPE S Y=""@61"";S Y=""@63"""
S DR(2,2.3216,2)="@62;D:DIPA(""X"")]"""" WARN^DGRP61(.DIPA,.Y);.04;@63;.05;.01;.02;.06"
Q
SETDR2 ; Set DR array to add MSE fields
S DR="@61;.03;S DIPA(""X"")=X;I X'="""" S:$$FV^DGRPMS(X)'=1 Y=""@62"";S DIPA(""FVP"")=$$FVP^DGRP61;I DIPA(""FVP"")=""^"" S Y=0;I DIPA(""FVP"")="""" D PRF^DGRPE S Y=""@61"";@62;S:'$$CMP^DGRP61(DIPA(""X"")) Y=""@63"";.04;@63;.05;.01;.02;.06"
Q
FVP() ; Prompt for FILIPINO VET PROOF
N DA,X,Y,DIR,DIRUT,DIROUT,DTOUT,DUOUT
S DIR(0)="2,.3214",DA=DFN
D ^DIR I Y=""!(Y="^") Q Y
Q Y
;
SET0(DA,DIPA) ; Set DIPA(0) to values of Service Branch and Service Component
K DIPA(0)
S DIPA(0)=$P($G(^DPT(DA(1),.3216,DA,0)),U,3,4)
Q
;
WARN(DIPA,Y) ;Warns that the Service Branch was changed so the
; Service Component was deleted
; Returns Y to skip component if the component should not be asked
; for this branch of service
I '$$CMP($G(DIPA("X"))) S Y="@63"
I $P($G(DIPA(0)),U,2)=""!($P($G(DIPA(0)),U)="") Q
I $P(DIPA(0),U)=DIPA("X") Q ;Service Branch didn't change
;
I '$D(DIQUIET) W !!,*7,"** WARNING - BRANCH OF SERVICE WAS CHANGED SO THE COMPONENT WAS DELETED",!
Q
;
CMP(X) ; Function to determine if service component is valid for
; branch of service ien in X 0 = invalid 1 = valid
; Component only valid for ARMY/AIR FORCE/MARINES/COAST GUARD/NOAA/USPHS/SPACE FORCE
Q $S('$G(X):0,X'>5!(X=9)!(X=10)!(X=15):1,1:0) ;DG*5.3*1044 - added 15 for SPACE FORCE branch of service
;
RUSURE() ; Confirmation prompt for deleting episode
N DIR,Y,X,DIRUT,DIROUT,DTOUT,DUOUT
S DIR(0)="YA",DIR("B")="NO"
S DIR("A")="Are you sure you want to delete this military service episode? "
D ^DIR I 'Y W !,"<< NOTHING DELETED >>" Q 0
Q 1
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGRP61 10136 printed Sep 23, 2025@20:31:34 Page 2
DGRP61 ;ALB/PJH,LBD,DJS,JAM,JAM,ARF - Patient MSDS History - List Manager Screen ;16 Oct 2017 16:04:16
+1 ;;5.3;Registration;**797,909,935,947,966,1014,1044**;Aug 13,1993;Build 13
+2 ;
EN(DFN) ;Main entry point to invoke the DGEN MSDS PATIENT list
+1 ; Input -- DFN Patient IEN
+2 ;
+3 DO WAIT^DICD
+4 DO EN^VALM("DGEN MSDS PATIENT")
+5 QUIT
+6 ;
HDR ;Header code
+1 NEW X
+2 SET VALMHDR(1)=$JUSTIFY("",25)_"MILITARY SERVICE DATA, SCREEN <6.1>"
+3 ;DG*5.3*1014 - ARF - sets patient data in the 2nd and 3rd entries in VALMHDR array
DO LISTHDR^DGRPU(2)
+4 ;D PID^VADPT ;DG*5.3*1014 begin comment previous code
+5 ;S VALMHDR(2)=$E("Patient: "_$P($G(^DPT(DFN,0)),U),1,30)
+6 ;S VALMHDR(2)=VALMHDR(2)_" ("_VA("BID")_")"
+7 ;S X="PATIENT TYPE UNKNOWN"
+8 ;I $D(^DPT(DFN,"TYPE")),$D(^DG(391,+^("TYPE"),0)) S X=$P(^(0),U,1)
+9 ;S VALMHDR(2)=$$SETSTR^VALM1(X,VALMHDR(2),60,80)
+10 ;S VALMHDR(3)=$J("",4)_"Service Branch/Component Service #"
+11 ;S VALMHDR(3)=VALMHDR(3)_" Entered Separated Discharge" ;DG*5.3*1014 end comment previous code
+12 SET VALMHDR(4)=$JUSTIFY("",4)_"Service Branch/Component Service #"
+13 SET VALMHDR(4)=VALMHDR(4)_" Entered Separated Discharge"
+14 QUIT
+15 ;
INIT ;Build patient MSDS screen
+1 DO CLEAN^VALM10
+2 KILL ^TMP("DGRP61",$JOB),DGSEL
+3 ;
+4 NEW GLBL
+5 SET GLBL=$NAME(^TMP("DGRP61",$JOB))
+6 DO GETMSE(DFN,GLBL,1)
+7 ;Check if any old MSEs didn't copy and display warning message
+8 IF $$WARNMSG^DGMSEUTL(DFN)
Begin DoDot:1
+9 SET VALMSG="**More MSEs available to view on History Screen**"
+10 DO MSG^VALM10(VALMSG)
End DoDot:1
+11 QUIT
+12 ;
GETMSE(DFN,GLBL,NUM) ;Load service episodes from .3216 array
+1 ; INPUT: DFN = Patient IEN
+2 ; GLBL = ^TMP global ref
+3 ; NUM = 1 - display line numbers
+4 NEW DGDATA,DGDATE,DGSUB,X1,X2,X
+5 ; DGSEL - selectable items, DGSEL("episode count") - episode count for DGSEL
+6 ; not all items may be selectable
+7 KILL DGSEL
SET VALMCNT=0
SET DGDATE=""
SET DGSEL("episode count")=0
+8 FOR
SET DGDATE=$ORDER(^DPT(DFN,.3216,"B",DGDATE),-1)
if 'DGDATE
QUIT
Begin DoDot:1
+9 SET DGSUB=$ORDER(^DPT(DFN,.3216,"B",DGDATE,""))
if 'DGSUB
QUIT
+10 SET DGDATA=$GET(^DPT(DFN,.3216,DGSUB,0))
if DGDATA=""
QUIT
+11 DO EPISODE(DGDATA,GLBL,NUM)
End DoDot:1
+12 QUIT
+13 ;
EPISODE(DGDATA,GLBL,NUM) ;Format individual service episode
+1 NEW DGFDD,DGRPSB,DGRPSC,DGRPSD,DGRPSE,DGRPSN,DGRPSS,Z
+2 ; increment episode count
+3 SET DGSEL("episode count")=DGSEL("episode count")+1
+4 SET DGRPSB=+$PIECE(DGDATA,U,3)
SET DGRPSC=$PIECE(DGDATA,U,4)
SET DGRPSN=$PIECE(DGDATA,U,5)
+5 ;Service Branch/Component
+6 SET Z=$SELECT($DATA(^DIC(23,DGRPSB,0)):$EXTRACT($PIECE(^(0),"^",1),1,15),1:"UNKNOWN")
+7 IF DGRPSC'=""
Begin DoDot:1
+8 NEW Z0
+9 SET Z0=$$SVCCOMP^DGRP6CL(DGRPSC)
if Z0=""
QUIT
+10 SET Z=Z_"/"_Z0
End DoDot:1
+11 ;Filipino vet proof
+12 IF $$FV^DGRPMS(DGRPSB)=1
SET Z=$EXTRACT(Z_$JUSTIFY("",21),1,21)_"("_$PIECE($GET(^DPT(DFN,.321)),U,14)_")"
+13 ;Service Number
+14 SET Z=Z_$JUSTIFY("",26-$LENGTH(Z))_$SELECT(DGRPSN]"":DGRPSN,1:"UNKNOWN")
+15 SET Z=Z_$JUSTIFY("",42-$LENGTH(Z))
+16 ;Entry and separation dates
+17 SET DGRPSE=$PIECE(DGDATA,U,1)
SET DGRPSS=$PIECE(DGDATA,U,2)
+18 SET X=$SELECT(DGRPSE]"":$$FMTE^XLFDT(DGRPSE,"5DZ"),1:"UNKNOWN ")
+19 SET Z=Z_$EXTRACT(X,1,10)_" "
+20 SET X=$SELECT(DGRPSS]"":$$FMTE^XLFDT(DGRPSS,"5DZ"),1:"UNKNOWN ")
+21 SET Z=Z_$EXTRACT(X,1,10)_" "
+22 ;DJS, Add FUTURE DISCHARGE DATE; DG*5.3*935
+23 ;DGFDD = FUTURE DISCHARGE DATE (internal)
+24 ;DGFDD("DISP") = FUTURE DISCHARGE DATE (display)
+25 SET DGFDD=$PIECE(DGDATA,U,8)
SET DGFDD("DISP")=$SELECT(DGFDD]"":$$FMTE^XLFDT(DGFDD,"5DZ"),1:"")
+26 ;Discharge type
+27 SET DGRPSD=+$PIECE(DGDATA,U,6)
+28 IF 'DGRPSD
SET Z=Z_"UNKNOWN"
+29 IF '$TEST
SET Z=Z_$SELECT($DATA(^DIC(25,+DGRPSD)):$EXTRACT($PIECE(^DIC(25,DGRPSD,0),"^",1),1,9),1:"UNKNOWN")
+30 ;
+31 SET VALMCNT=VALMCNT+1
+32 ; Add line numbers if NUM true
+33 IF $GET(NUM)
Begin DoDot:1
+34 ;DJS, Indicate MSE episode with FDD not editable or deletable; DG*5.3*935
+35 ; not selectable, put < > around number, stop
+36 IF $GET(DGRPV)!($PIECE(DGDATA,U,7)]"")!($PIECE(DGDATA,U,8)]"")
SET Z="<"_DGSEL("episode count")_"> "_Z
QUIT
+37 ; item is selectable, put into DGSEL, [ ] around number
+38 SET Z="["_DGSEL("episode count")_"] "_Z
SET DGSEL(DGSEL("episode count"))=DGRPSE
End DoDot:1
+39 ;
+40 ; Save to List Manager array for display
+41 SET @GLBL@(VALMCNT,0)=$SELECT($GET(NUM):Z,1:$JUSTIFY("",4)_Z)
+42 ; JAM; DG*5.3*947 - Track the array entries that are MSE data in the "1" subscript
+43 SET @GLBL@(VALMCNT,1)=""
+44 ; JAM; DG*5.3*947 - if Reason for Early Separation is present, include it in output
+45 ; JAM; DG*5.3*966 - If patient record has Separation Reason Code (piece 10), retrieve the Description from file #24
+46 ; otherwise get description from piece 9
+47 NEW RESDESC
+48 IF $PIECE(DGDATA,U,10)]""
Begin DoDot:1
+49 SET RESDESC=$$GET1^DIQ(26,$PIECE(DGDATA,U,10),.02)
End DoDot:1
+50 IF '$TEST
SET RESDESC=$PIECE(DGDATA,U,9)
+51 IF RESDESC]""
Begin DoDot:1
+52 ;use the DIWP api to format the text which can be longer than 80 chars
+53 NEW X,I,DIWL,DIWR,DIWF,RESLINE
+54 KILL ^UTILITY($JOB,"W")
+55 SET X="Early Separation Reason: "_RESDESC
SET DIWL=0
SET DIWR=80
SET DIWF=""
+56 DO ^DIWP
+57 MERGE RESDESC=^UTILITY($JOB,"W",0)
+58 FOR I=1:1:RESDESC
Begin DoDot:2
+59 SET RESLINE=RESDESC(I,0)
+60 SET VALMCNT=VALMCNT+1
SET @GLBL@(VALMCNT,0)=RESLINE
End DoDot:2
End DoDot:1
+61 ; end patch DG*5.3*947 changes
+62 ;
+63 ; if FDD found, add to display
if DGFDD
Begin DoDot:1
+64 SET VALMCNT=VALMCNT+1
SET @GLBL@(VALMCNT,0)=" Future Discharge Date: "_DGFDD("DISP")
End DoDot:1
+65 QUIT
+66 ;
HELP ;Help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ;Exit code
+1 DO CLEAN^VALM10
+2 DO CLEAR^VALM1
+3 KILL ^TMP("DGRP61",$JOB)
+4 QUIT
+5 ;
PEXIT ;DGEN MSDS MENU protocol exit code
+1 SET VALMSG="+ Next Screen - Prev Screen ?? More Actions"
+2 ;Reset after page up or down
+3 ;D XQORM
+4 QUIT
+5 ;
ACT(DGACT) ; Entry point for menu action selection
+1 ; INPUT: DGACT = "A" - Add - DGEN MSDS ADD protocol
+2 ; = "E" - Edit - DGEN MSDS EDIT protocol
+3 ; = "D" - Delete - DGEN MSDS DELETE protocol
+4 NEW DGX,DA,DIE,DIC,DIK,DIPA,DR,X,Y
+5 IF $GET(DGACT)=""
GOTO ACTQ
+6 IF $GET(DGRPV)
WRITE !,"View only. This action cannot be selected."
DO PAUSE^VALM1
GOTO ACTQ
+7 DO FULL^VALM1
+8 IF DGACT="A"
DO ADD
GOTO ACTQ
+9 IF '$ORDER(DGSEL(0))
Begin DoDot:1
+10 WRITE !,"There are no episodes to "_$SELECT(DGACT="E":"edit.",1:"delete.")
+11 IF $GET(VALMCNT)
DO HECHLP
+12 DO PAUSE^VALM1
End DoDot:1
GOTO ACTQ
+13 SET DGX=$$SEL(DGACT)
IF 'DGX
GOTO ACTQ
+14 SET DGX=$GET(DGSEL(DGX))
IF 'DGX
GOTO ACTQ
+15 SET DA(1)=DFN
SET DIC="^DPT("_DA(1)_",.3216,"
SET DIC(0)="BX"
SET X=DGX
+16 DO ^DIC
IF Y<0
WRITE !,"This episode is not in the patient's record."
DO PAUSE^VALM1
GOTO ACTQ
+17 SET DIPA("DA")=+Y
+18 IF DGACT="E"
KILL DA,DIC,DGFRDT
SET DIE="^DPT("
SET DA=DFN
DO SETDR1
DO ^DIE
GOTO ACTQ
+19 ; deletion, ask user first
+20 IF DGACT="D"
IF $$RUSURE
SET DIK=DIC
SET DA(1)=DFN
SET DA=DIPA("DA")
DO ^DIK
KILL DA,DIK
+21 ;
+22 ; DG*5.3*909 Potentially change Camp Lejeune to No with MSE changes
ACTQ ; menu action exit point
+1 DO INIT
SET VALMBCK="R"
DO SETCLNO^DGENCLEA
QUIT
+2 ;
ADD ; Add new MSE to #2.3216 sub-file
+1 NEW X,Y,DIK,DA,DR,DIE,NEXT,DGFRDT
+2 ; Get next record number in sub-file
+3 SET NEXT=$ORDER(^DPT(DFN,.3216,"A"),-1)
SET NEXT=NEXT+1
+4 DO ZNODE(1)
+5 ; Prompt for MSE fields
+6 SET DIE="^DPT("_DFN_",.3216,"
SET DA(1)=DFN
SET DA=NEXT
DO SETDR2
DO ^DIE
+7 IF X["BAD"
SET DIK="^DPT("_DFN_",.3216,"
SET DA(1)=DFN
SET DA=NEXT
DO ^DIK
+8 ; Check if new record is missing or incomplete
+9 IF '$DATA(^DPT(DFN,.3216,NEXT))
DO ZNODE(-1)
QUIT
+10 IF '$PIECE(^DPT(DFN,.3216,NEXT,0),U)
Begin DoDot:1
+11 SET DIK="^DPT("_DFN_",.3216,"
SET DA(1)=DFN
SET DA=NEXT
DO ^DIK
DO ZNODE(-1)
End DoDot:1
QUIT
+12 ;
+13 ; File FILIPINO VET PROOF, if set
+14 IF $GET(DIPA("FVP"))]""
Begin DoDot:1
+15 KILL DA,DR
SET DIE="^DPT("
SET DA=DFN
SET DR=".3214///^S X=DIPA(""FVP"")"
+16 DO ^DIE
End DoDot:1
+17 QUIT
+18 ;
SEL(ACT) ; function, prompt for episode to edit/delete
+1 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+2 ; range is 1 to episode count, must be in DGSEL to be selectable
+3 SET DIR(0)="NAO^1:"_DGSEL("episode count")_"^K:'$D(DGSEL(X)) X"
+4 SET DIR("A")="Select Episode: "
+5 SET DIR("?")="^D SELHLP^DGRP61(ACT)"
+6 DO ^DIR
IF 'Y
QUIT 0
+7 QUIT Y
+8 ;
SELHLP(ACT) ; Help message for episode prompt
+1 WRITE !,"Select an episode to ",$SELECT(ACT="E":"edit.",1:"delete.")
+2 WRITE !,"Only numbers in square brackets [ ] are selectable."
+3 DO HECHLP
+4 NEW DIR
DO PAUSE^VALM1
+5 QUIT
HECHLP ; Help message for episodes that can only be changed by HEC
+1 WRITE !,"Angled brackets < > indicate episodes that cannot be changed in VistA."
+2 WRITE !,"Please contact the HECAlert mail group or the HEC if you need to update"
+3 WRITE !,"this information."
+4 QUIT
+5 ;
ZNODE(VAL) ; Update zero node of MSE multiple .3216
+1 if '$GET(VAL)
QUIT
if '$GET(DFN)
QUIT
+2 NEW ZNODE
+3 SET ZNODE=$GET(^DPT(DFN,.3216,0))
+4 SET ^DPT(DFN,.3216,0)="^2.3216D^"_($PIECE(ZNODE,U,3)+VAL)_U_($PIECE(ZNODE,U,4)+VAL)
+5 QUIT
SETDR1 ; Set DR array to edit MSE fields
+1 SET DR="I '$G(DIPA(""DA"")) S Y=0;.3216////^S X=""`""_DIPA(""DA"");.3214///^S X=$G(DIPA(""FVP""))"
+2 SET DR(2,2.3216)="D SET0^DGRP61(.DA,.DIPA);@61;.03;S DIPA(""X"")=X;I X'="""" S:$$FV^DGRPMS(X)'=1 Y=""@62"";S DIPA(""FVP"")=$$FVP^DGRP61"
+3 SET DR(2,2.3216,1)="I DIPA(""FVP"")=""^"" K DIPA(""FVP"") S Y=0;I DIPA(""FVP"")="""" D PRF^DGRPE S Y=""@61"";S Y=""@63"""
+4 SET DR(2,2.3216,2)="@62;D:DIPA(""X"")]"""" WARN^DGRP61(.DIPA,.Y);.04;@63;.05;.01;.02;.06"
+5 QUIT
SETDR2 ; Set DR array to add MSE fields
+1 SET DR="@61;.03;S DIPA(""X"")=X;I X'="""" S:$$FV^DGRPMS(X)'=1 Y=""@62"";S DIPA(""FVP"")=$$FVP^DGRP61;I DIPA(""FVP"")=""^"" S Y=0;I DIPA(""FVP"")="""" D PRF^DGRPE S Y=""@61"";@62;S:'$$CMP^DGRP61(DIPA(""X"")) Y=""@63"";.04;@63;.05;.01;.02;.06"
+2 QUIT
FVP() ; Prompt for FILIPINO VET PROOF
+1 NEW DA,X,Y,DIR,DIRUT,DIROUT,DTOUT,DUOUT
+2 SET DIR(0)="2,.3214"
SET DA=DFN
+3 DO ^DIR
IF Y=""!(Y="^")
QUIT Y
+4 QUIT Y
+5 ;
SET0(DA,DIPA) ; Set DIPA(0) to values of Service Branch and Service Component
+1 KILL DIPA(0)
+2 SET DIPA(0)=$PIECE($GET(^DPT(DA(1),.3216,DA,0)),U,3,4)
+3 QUIT
+4 ;
WARN(DIPA,Y) ;Warns that the Service Branch was changed so the
+1 ; Service Component was deleted
+2 ; Returns Y to skip component if the component should not be asked
+3 ; for this branch of service
+4 IF '$$CMP($GET(DIPA("X")))
SET Y="@63"
+5 IF $PIECE($GET(DIPA(0)),U,2)=""!($PIECE($GET(DIPA(0)),U)="")
QUIT
+6 ;Service Branch didn't change
IF $PIECE(DIPA(0),U)=DIPA("X")
QUIT
+7 ;
+8 IF '$DATA(DIQUIET)
WRITE !!,*7,"** WARNING - BRANCH OF SERVICE WAS CHANGED SO THE COMPONENT WAS DELETED",!
+9 QUIT
+10 ;
CMP(X) ; Function to determine if service component is valid for
+1 ; branch of service ien in X 0 = invalid 1 = valid
+2 ; Component only valid for ARMY/AIR FORCE/MARINES/COAST GUARD/NOAA/USPHS/SPACE FORCE
+3 ;DG*5.3*1044 - added 15 for SPACE FORCE branch of service
QUIT $SELECT('$GET(X):0,X'>5!(X=9)!(X=10)!(X=15):1,1:0)
+4 ;
RUSURE() ; Confirmation prompt for deleting episode
+1 NEW DIR,Y,X,DIRUT,DIROUT,DTOUT,DUOUT
+2 SET DIR(0)="YA"
SET DIR("B")="NO"
+3 SET DIR("A")="Are you sure you want to delete this military service episode? "
+4 DO ^DIR
IF 'Y
WRITE !,"<< NOTHING DELETED >>"
QUIT 0
+5 QUIT 1
+6 ;
