- 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 Feb 19, 2025@00:21:43 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 ;