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

DGRP61.m

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