BPSVRX2 ;SLT - View ECME Prescription ;7/18/2011
;;1.0;E CLAIMS MGMT ENGINE;**11**;JUN 2004;Build 27
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; Reference to $$RDIS^DGRPDB supported by DBIA #4807
;
Q
;
DGELST(RXIEN,FILL,VIEWTYPE,BPSSNUM) ; View Registration Eligibility Status screen
N DFN,X,RPTYPE,LC,PAT,X1,SPS,Z,RPW,I,RP,RPX,Z1,LINE,NA,RPU,SP,MBCK,RPE,AAC
N I1,SHAD,CV,I3,LEN,MAXLEN,INST,INSTP
I '$D(ZTQUEUED) W !,"Compiling data for View Registration Eligibility Status ... "
K ^TMP($J,"BPSELST")
S LC=0,SP=" ",MAXLEN=80
S DFN=+$$RXAPI1^BPSUTIL1(RXIEN,2,"I")
S PAT=$$SSNNM(DFN)
F I=0,.29,.3,.31,.32,.321,.36,.362,"TYPE","VET" S RP(I)=$G(^DPT(DFN,I))
S X=$S(RP("TYPE")="":0,1:+RP("TYPE"))
S RPTYPE=$S(X:$$EXTERNAL^DILFD(2,391,"",X),1:"PATIENT TYPE UNKNOWN")
S X1=MAXLEN-($L(PAT)+$L(RPTYPE))
S LC=LC+1,^TMP($J,"BPSELST",LC,0)=PAT_$$PAD(X1-1)_RPTYPE
S X="",$P(X,"=",MAXLEN)="",RPU="UNANSWERED"
S LC=LC+1,^TMP($J,"BPSELST",LC,0)=X
; section 1
S Z=1,LINE=$$WW(Z)_$$PAD(7)_"Patient Type: "
S RPX=RP("TYPE"),Z=$$GET1^DIQ(391,RPX,.01,"I")
S Z=$S(Z]"":Z,1:RPU),Z1=34
S LINE=LINE_Z_$$PAD(Z1-$L(Z))_"Veteran: "
S RPX=RP("VET"),(X,Z1)=1
S LINE=LINE_$$YN(X,RPX,Z1)
S LC=LC+1,^TMP($J,"BPSELST",LC,0)=LINE
;
S LINE=$$PAD(9)_"Svc Connected: "
S RPX=RP(.3),X=1,Z1=31,NA=$S($P(RP("VET"),U)="Y":0,1:1)
S LINE=LINE_$$YN2(NA,X,RPX,Z1,.Z)
S LINE=LINE_"SC Percent: "
I $E(Z)'="Y" D
. S LINE=LINE_"N/A"
. S LC=LC+1,^TMP($J,"BPSELST",LC,0)=LINE
I $E(Z)="Y" D
. S X=$P(RPX,U,2)
. S LINE=LINE_$S(X="":"UNANSWERED",1:+X_"%")
. S LC=LC+1,^TMP($J,"BPSELST",LC,0)=LINE
. S X=$P(RP(.3),U),NA=$S(X'="Y":1,1:0)
. S LINE=$$PAD(9)_"SC Award Date: "_$$DATENP(RPX,12)
. S LINE=LINE_$$PAD(53-$L(LINE))_"Unemployable: "_$$YN2(NA,5,RPX,0)
. S LC=LC+1,^TMP($J,"BPSELST",LC,0)=LINE
. S LINE=$$PAD(19)_"P&T: "_$$YN2(NA,4,RPX,23)
. I $P(RP(.3),U,4)["Y" S LINE=LINE_"P&T Effective Date: "
. S:$P(RP(.3),U,13)']"" LINE=LINE_"UNANSWERED"
. I $P(RP(.3),U,13)]"" D
. . S Y=$$FMTE^XLFDT($P(RP(.3),U,13))
. . S LINE=LINE_$G(Y)
. S LC=LC+1,^TMP($J,"BPSELST",LC,0)=LINE
;
S LINE=$$PAD(9)_"Rated Incomp.: ",X=$$YN3(RP(.29),12)
S LINE=LINE_X
I X["Y" D
. S LINE=LINE_$$PAD(3)_"Date (CIVIL): "_$$DATENP(RP(.29),2)
. S LINE=LINE_$$PAD(4)_"Date (VA): "_$$DATENP(RP(.29),1)
S LC=LC+1,^TMP($J,"BPSELST",LC,0)=LINE
;
S RPX=RP(.31)
S LINE=$$PAD(10)_"Claim Number: "_$S($P(RPX,U,3)]"":$P(RPX,U,3),1:RPU)
S LC=LC+1,^TMP($J,"BPSELST",LC,0)=LINE
;
S INST="",INSTP=$P(RP(.31),U,4)
I INSTP S INST=$$EXTERNAL^DILFD(2,.314,"",INSTP)
S LINE=$$PAD(11)_"Folder Loc.: "_$S(INST]"":INST,INSTP:"INVALID",1:"UNANSWERED")
S LC=LC+1,^TMP($J,"BPSELST",LC,0)=LINE
; section 2
S Z=2,LINE=$$WW(Z)_$$PAD(3)_"Aid & Attendance: "
S Z=$$YN3(RP(.362),12)
S Z1=31
S LINE=LINE_Z_$$PAD(Z1-$L(Z))_"Housebound: "
S Z=$$YN3(RP(.362),13)
S LINE=LINE_Z
S LC=LC+1,^TMP($J,"BPSELST",LC,0)=LINE
;
S LINE=$$PAD(12)_"VA Pension: ",Z=$$YN3(RP(.362),14)
S Z1=28
S LINE=LINE_Z_$$PAD(Z1-$L(Z))_"VA Disability: ",Z=$$YN3(RP(.3),11)
S LINE=LINE_Z
S MBCK=$$MBCK(Z)
S LC=LC+1,^TMP($J,"BPSELST",LC,0)=LINE
;
S LINE=$$PAD(4)_"Total Check Amount: "
S X=$$DISP(RP(.362),20,'MBCK)
S LINE=LINE_$S(X:"$"_X,1:X)
S LC=LC+1,^TMP($J,"BPSELST",LC,0)=LINE
;
S LINE=$$PAD(10)_"GI Insurance: "
S Z=$$YN3(RP(.362),17),Z1=35
S LINE=LINE_Z_$$PAD(Z1-$L(Z))_"Amount: "
S X=$$DISP(RP(.362),6)
S LINE=LINE_$S(X:"$"_X,1:X)
S LC=LC+1,^TMP($J,"BPSELST",LC,0)=LINE
; section 3
S Z=3,LINE=$$WW(Z)
S RPE=+RP(.36),Z=$$GET1^DIQ(8,+RPE,.01,"I"),Z=$S(Z]"":Z,1:RPU)
S LINE=LINE_$$PAD(2)_"Primary Elig Code: "_Z
S LC=LC+1,^TMP($J,"BPSELST",LC,0)=LINE
;
;Agency/Country
S X=$$EXTERNAL^DILFD(2,.361,"",+$P(RP(.36),U))
S AAC=$S($D(RP(.36)):$S(X]"":+$P(RP(0),U,4),1:""),1:"")
S AAC(1)=$S('$D(RP("VET")):"",RP("VET")'="N":"",AAC=4:"A",AAC=5:"C",1:"")
I AAC(1)]"" D
. S X=$$EXTERNAL^DILFD(2,.309,"",+$P(RP(.3),U,9))
. S LINE=$$PAD(8)_"Agency/Country: "_$S(X]"":X,1:RPU)
. S LC=LC+1,^TMP($J,"BPSELST",LC,0)=LINE
;
S LINE=$$PAD(4)_"Other Elig Code(s): "
S I1=0,SPS="",$P(SPS,SP,25)=""
F I=0:0 S I=$O(^DPT("AEL",DFN,I)) Q:'I D
. S X=$$EXTERNAL^DILFD(2,.361,"",I)
. I X]"",I'=RPE D
. . S I1=I1+1
. . I I1>1 S LINE=SPS_X
. . E S LINE=LINE_X
. . S LC=LC+1,^TMP($J,"BPSELST",LC,0)=LINE
I 'I1 D
. S LINE=LINE_"NO ADDITIONAL ELIGIBILITIES IDENTIFIED"
. S LC=LC+1,^TMP($J,"BPSELST",LC,0)=LINE
;
S RPX=+$P(RP(.32),U,3)
S LINE=$$PAD(5)_"Period of Service: "_$S(RPX:$$EXTERNAL^DILFD(2,.323,"",RPX),1:RPU)
S LC=LC+1,^TMP($J,"BPSELST",LC,0)=LINE
;
I $$ODS(DFN) D ;ODS system on
. S RPX=$G(^DPT(DFN,"ODS"))
. S LINE=$$PAD(6)_"Recalled to Duty: "
. S LINE=LINE_$S($P(RPX,U,2)=1:"FROM NATIONAL GUARDS",$P(RPX,U,2)=2:"FROM RESERVES",$P(RPX,U,2)=0:"NO",1:RPU)
. S LC=LC+1,^TMP($J,"BPSELST",LC,0)=LINE
. ;
. S LINE=$$PAD(18)_"Rank: "_$S(+$P(RPX,U,3):$$EXTERNAL^DILFD(2,11500.03,"",$P(RPX,U,3)),1:RPU)
. S LC=LC+1,^TMP($J,"BPSELST",LC,0)=LINE
;
;Combat Vet Eligibility
S SHAD=$P(RP(.321),U,15) ;SHAD Indicator
S CV=$$CVEDT(DFN)
I +$G(CV)=1 D
. S LINE="<3.1> Combat Vet Elig.: "_$S($P(CV,U,3)=1:"ELIGIBLE",$P(CV,U,3)=0:"EXPIRED",1:"")
. I $P($G(CV),U,2)]"" D
. . S Y=$$FMTE^XLFDT($P(CV,U,2))
. . S LINE=LINE_$$PAD(1)_"End Date: "_Y
. I SHAD=1 D
. . S LINE=LINE_$$PAD(55-$L(LINE))_"<3.2>Proj 112/SHAD: YES"
. S LC=LC+1,^TMP($J,"BPSELST",LC,0)=LINE
I (+$G(CV)'=1)&(SHAD=1) D
. S LINE=$$PAD(55)_"<3.2>Proj 112/SHAD: YES"
. S LC=LC+1,^TMP($J,"BPSELST",LC,0)=LINE
;
;Service connected conditions
S LINE="",LC=LC+1,^TMP($J,"BPSELST",LC,0)=LINE ;blank line
S Z=4,LINE=$$WW(Z)_" Service Connected Conditions as stated by applicant"
S LC=LC+1,^TMP($J,"BPSELST",LC,0)=LINE
S X="",$P(X,"-",52)=""
S SPS=$$PAD(4)
S LINE=SPS_X
S LC=LC+1,^TMP($J,"BPSELST",LC,0)=LINE
S LINE=SPS
S (I,I3,LEN)=0
F S I=$O(^DPT(DFN,.373,I)) Q:'I D
. N I373
. S I373=^DPT(DFN,.373,I,0)
. S I1=$P(I373,U)_" ("_+$P(I373,U,2)_"%), "
. S I3=I
. I $L(LINE)+$L(I1)>MAXLEN D
. . S LC=LC+1,^TMP($J,"BPSELST",LC,0)=LINE
. . S LINE=SPS_I1
. E D
. . S LINE=LINE_I1
I 'I3 D
. S LINE=LINE_"NONE STATED"
. S LC=LC+1,^TMP($J,"BPSELST",LC,0)=LINE
;
D UPDATE^BPSVRX($NA(^TMP($J,"BPSELST")),"","","View Registration Eligibility Status",BPSSNUM)
K ^TMP($J,"BPSELST")
DGELSTX ;
Q
;
DGELV(RXIEN,FILL,VIEWTYPE,BPSSNUM) ; View Registration Eligibility Verification screen
N LC,SP,MAXLEN,DFN,PAT,X,RPTYPE,X1,SPS,RPU,I,RP,Z,RPX,Z1,RPVR,Y,RPNA,STATID,VMETH
N EC,EFF,I3,ARR,AI,IVC,VA200,LINE
I '$D(ZTQUEUED) W !,"Compiling data for View Registration Eligibility Verification ... "
K ^TMP($J,"BPSELV")
S LC=0,SP=" ",MAXLEN=80
S DFN=+$$RXAPI1^BPSUTIL1(RXIEN,2,"I")
F I=.3,.32,.36,.361,"TYPE","VET" S RP(I)=$G(^DPT(DFN,I))
S PAT=$$SSNNM(DFN)
S RPTYPE="PATIENT TYPE UNKNOWN"
I RP("TYPE")]"" D
. S RPTYPE=$$GET1^DIQ(391,RP("TYPE"),.01,"I")
S X1=MAXLEN-($L(PAT)+$L(RPTYPE))
S LC=LC+1,^TMP($J,"BPSELV",LC,0)=PAT_$$PAD(X1-1)_RPTYPE
S X="",$P(X,"=",MAXLEN)="",RPU="UNANSWERED",RPNA="NOT APPLICABLE"
S LC=LC+1,^TMP($J,"BPSELV",LC,0)=X
; section 1
S Z=1,Z1=28,LINE=$$WW(Z)_" Eligibility Status: "
S RPX=RP(.361)
S X=$P(RPX,U),Z=$S(X']"":"NOT VERIFIED",X="V":"VERIFIED",X="R":"PENDING RE-VERIFICATION",1:"PENDING VERIFICATION")
S LINE=LINE_Z_$$PAD(Z1-$L(Z))_"Status Date: "
S RPVR=$S(X]"":1,1:0)
S Y=$P(RPX,U,2) I Y]"" S Y=$$FMTE^XLFDT(Y)
S LINE=LINE_$S(Y]"":Y,RPVR:RPU,1:RPNA)
S LC=LC+1,^TMP($J,"BPSELV",LC,0)=LINE
;
S STATID=+$P(RPX,U,6)
S LINE=$$PAD(5)_"Status Entered By: "
S VA200=$$GET1^DIQ(200,STATID,.01,"I")
S LINE=LINE_$S(VA200]"":VA200_" (#"_STATID_")",RPVR:RPU,1:RPNA)
S LC=LC+1,^TMP($J,"BPSELV",LC,0)=LINE
;
S LINE=$$PAD(6)_"Interim Response: "
S Y=$P(RPX,U,4) I Y]"" S Y=$$FMTE^XLFDT(Y)
S LINE=LINE_$S(Y]"":Y,1:RPU_" (NOT REQUIRED)")
S LC=LC+1,^TMP($J,"BPSELV",LC,0)=LINE
;
S SPS=$$PAD(9)
S VMETH=$P(RPX,U,5)
S LINE=SPS_"Verif. Method: "_$S(VMETH]"":VMETH,RPVR:RPU,1:RPNA)
S LC=LC+1,^TMP($J,"BPSELV",LC,0)=LINE
;
; SPS same as above
S LINE=SPS_"Verif. Source: "_$S($P(RPX,U,3)="H":"HEC",$P(RPX,U,3)="V":"VISTA",1:"NOT AVAILABLE")
S LC=LC+1,^TMP($J,"BPSELV",LC,0)=LINE
;
S Z=2,LINE=$$WW(Z)_$$PAD(5)_"Money Verified: "
S Y=$P(RP(.3),U,6) I Y]"" S Y=$$FMTE^XLFDT(Y)
S LINE=LINE_$S(Y]"":Y,1:"NOT VERIFIED")
S LC=LC+1,^TMP($J,"BPSELV",LC,0)=LINE
;
S Z=3,LINE=$$WW(Z)_$$PAD(3)_"Service Verified: "
S Y=$P(RP(.32),U,2) I Y]"" S Y=$$FMTE^XLFDT(Y)
S LINE=LINE_$S(Y]"":Y,1:"NOT VERIFIED")
S LC=LC+1,^TMP($J,"BPSELV",LC,0)=LINE
;
S SPS=$$PAD(1)
S Z=4,LINE=$$WW(Z)_SPS_"Rated Disabilities: "
S IVC=$$GET1^DIQ(391,+RP("TYPE"),.02,"I")
I $P(RP("VET"),U)'="Y",$S(IVC="":1,IVC:0,1:1) D Q
. S LINE=LINE_RPNA_" - NOT A VETERAN"
. S LC=LC+1,^TMP($J,"BPSELV",LC,0)=LINE
. D ELVSTOR($NA(^TMP($J,"BPSELV")),BPSSNUM)
; implied else continues here
S EC=$P(RP(.36),U)
I EC S EC=$$GET1^DIQ(8,EC,.01,"I")
S LINE=LINE_SPS_"SC%: "_$S(EC="NSC":"",$P(RP(.3),U,2)="":"",1:$P(RP(.3),U,2))
S EFF=$P(RP(.3),U,14)
I EFF]"" S Y=EFF S Y=$$FMTE^XLFDT(Y) S EFF=Y
S LINE=LINE_$$PAD(4)_"EFF. DATE OF COMBINED SC%: "_EFF
S LC=LC+1,^TMP($J,"BPSELV",LC,0)=LINE
;
S LINE=$$PAD(55)_"Orig"
S LINE=LINE_$$PAD(70-$L(LINE))_"Curr"
S LC=LC+1,^TMP($J,"BPSELV",LC,0)=LINE
;
S LINE=$$PAD(3)_"Rated Disability"
S LINE=LINE_$$PAD(46-$L(LINE))_"Extr"
S LINE=LINE_$$PAD(55-$L(LINE))_"Eff Dt"
S LINE=LINE_$$PAD(70-$L(LINE))_"Eff Dt"
S LC=LC+1,^TMP($J,"BPSELV",LC,0)=LINE
;
I '$$RDIS^DGRPDB(DFN,.ARR) D ;IA #4807
. S LINE="NONE STATED"
. S LC=LC+1,^TMP($J,"BPSELV",LC,0)=LINE
E D
. S (I3,AI)=0
. F S AI=$O(ARR(AI)) Q:'AI D
. . S I3=I3+1
. . N CURR,ORIG,BP0,BP1,BP2,BP4,BP5,BP6
. . I $G(ARR(AI))']"" Q
. . S BP1=$$EXTERNAL^DILFD(2.04,.01,"",+ARR(AI))
. . I BP1="" Q
. . S BP0=$$EXTERNAL^DILFD(2.04,3,"",$P(ARR(AI),U,3))
. . S BP2="("_$S($P(ARR(AI),U,3)=1:$P(ARR(AI),U,2)_"% SC",$P(ARR(AI),U,3)]"":$P(ARR(AI),U,2)_"% NSC",1:"unspec")_")"
. . S BP4=$P(ARR(AI),U,4),BP5=$P(ARR(AI),U,5),BP6=$P(ARR(AI),U,6)
. . I BP5]"" S Y=BP5 S Y=$$FMTE^XLFDT(Y) S ORIG=Y
. . I BP6]"" S Y=BP6 S Y=$$FMTE^XLFDT(Y) S CURR=Y
. . S LINE=$G(BP0)_"-"_BP1_BP2
. . S LINE=LINE_$$PAD(47-$L(LINE))_$G(BP4)
. . S LINE=LINE_$$PAD(50-$L(LINE))_" - "
. . S LINE=LINE_$$PAD(53-$L(LINE))_$G(ORIG)
. . S LINE=LINE_$$PAD(64-$L(LINE))_" - "
. . S LINE=LINE_$$PAD(68-$L(LINE))_$G(CURR)
. . S LC=LC+1,^TMP($J,"BPSELV",LC,0)=LINE
. I 'I3 D
. . S LINE="NONE STATED"
. . S LC=LC+1,^TMP($J,"BPSELV",LC,0)=LINE
;
D ELVSTOR($NA(^TMP($J,"BPSELV")),BPSSNUM)
DGELVX ;
Q
;
ELVSTOR(ARRNAME,BPSSNUM) ;
D UPDATE^BPSVRX(ARRNAME,"","","View Registration Eligibility Verification",BPSSNUM)
K @ARRNAME
Q
;
SSNNM(DFN) ; SSN and name
N X,SSN
S X=$G(^DPT(+DFN,0))
S SSN=$P(X,U,9),SSN=$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,10)
S X=$P(X,U)_"; "_SSN
Q X
;
WW(Z) ;Write number on screens for display (Z=number)
S Z="<"_Z_">"
Q Z
;
WW1(Z,Z1) ;spacing for screen display (Z=item to print)
N Z2
F Z2=1:1:(Z1-$L(Z)) S Z=Z_" "
Q Z
;
YN(X,RPX,Z1) ;
N Z
S Z=$S($P(RPX,U,X)="Y":"YES",$P(RPX,U,X)="N":"NO",$P(RPX,U,X)="U":"UNKNOWN",1:"UNANSWERED")
Q $$WW1(Z,Z1)
;
YN2(NA,X,RPX,Z1,Z) ;
S Z=$S(NA:"N/A",$P(RPX,U,X)="Y":"YES",$P(RPX,U,X)="N":"NO",$P(RPX,U,X)="U":"UNKNOWN",1:"UNANSWERED")
Q $$WW1(Z,Z1)
;
YN3(N,P) ; code from YN2^DG1010P0
; Ext Val of YES/NO given node & piece.
;IN: N -- Val of Node
; P -- Piece
;OUT:[RETURN] -- Ext Val
S X=$P(N,U,P)
Q $S((X="Y"):"YES",(X="N"):"NO",(X="U"):"UNKNOWN",(X=""):"UNANSWERED",("0"[X):"NO",("12"[X):"YES",("3"[X):"UNKNOWN",1:"INVALID")
;
DATENP(N,P,NA,BL) ;
; Returns External Value of Date in the Pth '^' piece of 'N'
; Output is modified by NA & BL as per $$UNK[see above]
; INPUT:
; N -- Contents of a node
; P -- the Pth '^' piece
; NA,BL -- Optional output modifiers
; OUTPUT[Returned] -- X
; OUTPUT[Set] -- DGUNK =1 if NA=1 or X=""
N Y,UNK
S Y=$$DISP(N,P,+$G(NA),$G(BL),.UNK)
I 'UNK S Y=$$FMTE^XLFDT(Y)
Q Y
;
DISP(N,P,NA,BL,UNK) ;
; Returns the Pth '^' piece of 'N'
; Output is modified by NA & BL as per $$UNK[see above]
; INPUT: N -- Contents of a node
; P -- the Pth '^' piece
; NA,BL -- Optional output modifiers
; OUTPUT[Returned] -- X
; OUTPUT[Set] -- DGUNK =1 if NA=1 or X=""
N X
S X=$P($G(N),U,P)
S UNK=$S($G(NA):1,(X]""):0,1:1)
Q $S(($G(NA)):"NOT APPLICABLE",(X]""):X,($G(BL)):"",1:"UNANSWERED")
;
MBCK(X) ;flag for any MB Y/N fields = yes
N MBCK
S MBCK=$S($G(MBCK):1,(X="Y"):1,1:0)
Q MBCK
;
CVEDT(DFN,TDT) ;Provide Combat Vet Eligibility End Date, if eligible
;Supported DBIA #4156
;Input: DFN - Patient file IEN
; TDT - Treatment date (optional),
; DT is default
;Output :RESULT=(1,0,-1)^End Date (if populated, otherwise null)^CV
; Eligible on DGDT(1,0)^is patient eligible on input date?
; (piece 1) 1 - qualifies as a CV
; 0 - does not qualify as a CV
; -1 - bad DFN or date
; (piece 3) 1 - vet was eligible on date specified (or DT)
; 0 - vet was not eligible on date specified (or DT)
;
N RESULT
S RESULT=""
I $G(DFN)="" Q -1
I '$D(^DPT(DFN)) Q -1
;if time sent in, drop time
I $G(TDT)']"" S TDT=DT
I TDT?7N1"."1.6N S TDT=$E(TDT,1,7)
I TDT'?7N Q -1
S RESULT=$$GET1^DIQ(2,DFN_",",.5295,"I")
I $G(RESULT)']"" Q 0
; if treatment date is earlier or equal to end date, veteran is eligible
S RESULT=$S(TDT'>RESULT:RESULT_"^1",1:RESULT_"^0")
S RESULT=$S($G(RESULT):1_U_RESULT,1:0)
Q RESULT
;
ODS(DFN) ;ODS software check
N ODS,POS
S ODS=$$GET1^DIQ(11500.5,1,.02,"I")
I 'ODS Q ODS
S ODS=0
I $D(^DPT(DFN,.32)) D
. S POS=$$GET1^DIQ(2,DFN,.323,"I")
. S:POS=6 ODS=1
Q ODS
;
PAD(LEN) ; space padding function
; Input:
; LEN (r) --> padding length
; Output:
; A string of space characters
;
N SPS,SP
S SP=$C(32)
S SPS="",$P(SPS,SP,LEN+1)=""
Q SPS
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HBPSVRX2 14236 printed Sep 23, 2025@19:29:53 Page 2
BPSVRX2 ;SLT - View ECME Prescription ;7/18/2011
+1 ;;1.0;E CLAIMS MGMT ENGINE;**11**;JUN 2004;Build 27
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; Reference to $$RDIS^DGRPDB supported by DBIA #4807
+5 ;
+6 QUIT
+7 ;
DGELST(RXIEN,FILL,VIEWTYPE,BPSSNUM) ; View Registration Eligibility Status screen
+1 NEW DFN,X,RPTYPE,LC,PAT,X1,SPS,Z,RPW,I,RP,RPX,Z1,LINE,NA,RPU,SP,MBCK,RPE,AAC
+2 NEW I1,SHAD,CV,I3,LEN,MAXLEN,INST,INSTP
+3 IF '$DATA(ZTQUEUED)
WRITE !,"Compiling data for View Registration Eligibility Status ... "
+4 KILL ^TMP($JOB,"BPSELST")
+5 SET LC=0
SET SP=" "
SET MAXLEN=80
+6 SET DFN=+$$RXAPI1^BPSUTIL1(RXIEN,2,"I")
+7 SET PAT=$$SSNNM(DFN)
+8 FOR I=0,.29,.3,.31,.32,.321,.36,.362,"TYPE","VET"
SET RP(I)=$GET(^DPT(DFN,I))
+9 SET X=$SELECT(RP("TYPE")="":0,1:+RP("TYPE"))
+10 SET RPTYPE=$SELECT(X:$$EXTERNAL^DILFD(2,391,"",X),1:"PATIENT TYPE UNKNOWN")
+11 SET X1=MAXLEN-($LENGTH(PAT)+$LENGTH(RPTYPE))
+12 SET LC=LC+1
SET ^TMP($JOB,"BPSELST",LC,0)=PAT_$$PAD(X1-1)_RPTYPE
+13 SET X=""
SET $PIECE(X,"=",MAXLEN)=""
SET RPU="UNANSWERED"
+14 SET LC=LC+1
SET ^TMP($JOB,"BPSELST",LC,0)=X
+15 ; section 1
+16 SET Z=1
SET LINE=$$WW(Z)_$$PAD(7)_"Patient Type: "
+17 SET RPX=RP("TYPE")
SET Z=$$GET1^DIQ(391,RPX,.01,"I")
+18 SET Z=$SELECT(Z]"":Z,1:RPU)
SET Z1=34
+19 SET LINE=LINE_Z_$$PAD(Z1-$LENGTH(Z))_"Veteran: "
+20 SET RPX=RP("VET")
SET (X,Z1)=1
+21 SET LINE=LINE_$$YN(X,RPX,Z1)
+22 SET LC=LC+1
SET ^TMP($JOB,"BPSELST",LC,0)=LINE
+23 ;
+24 SET LINE=$$PAD(9)_"Svc Connected: "
+25 SET RPX=RP(.3)
SET X=1
SET Z1=31
SET NA=$SELECT($PIECE(RP("VET"),U)="Y":0,1:1)
+26 SET LINE=LINE_$$YN2(NA,X,RPX,Z1,.Z)
+27 SET LINE=LINE_"SC Percent: "
+28 IF $EXTRACT(Z)'="Y"
Begin DoDot:1
+29 SET LINE=LINE_"N/A"
+30 SET LC=LC+1
SET ^TMP($JOB,"BPSELST",LC,0)=LINE
End DoDot:1
+31 IF $EXTRACT(Z)="Y"
Begin DoDot:1
+32 SET X=$PIECE(RPX,U,2)
+33 SET LINE=LINE_$SELECT(X="":"UNANSWERED",1:+X_"%")
+34 SET LC=LC+1
SET ^TMP($JOB,"BPSELST",LC,0)=LINE
+35 SET X=$PIECE(RP(.3),U)
SET NA=$SELECT(X'="Y":1,1:0)
+36 SET LINE=$$PAD(9)_"SC Award Date: "_$$DATENP(RPX,12)
+37 SET LINE=LINE_$$PAD(53-$LENGTH(LINE))_"Unemployable: "_$$YN2(NA,5,RPX,0)
+38 SET LC=LC+1
SET ^TMP($JOB,"BPSELST",LC,0)=LINE
+39 SET LINE=$$PAD(19)_"P&T: "_$$YN2(NA,4,RPX,23)
+40 IF $PIECE(RP(.3),U,4)["Y"
SET LINE=LINE_"P&T Effective Date: "
+41 if $PIECE(RP(.3),U,13)']""
SET LINE=LINE_"UNANSWERED"
+42 IF $PIECE(RP(.3),U,13)]""
Begin DoDot:2
+43 SET Y=$$FMTE^XLFDT($PIECE(RP(.3),U,13))
+44 SET LINE=LINE_$GET(Y)
End DoDot:2
+45 SET LC=LC+1
SET ^TMP($JOB,"BPSELST",LC,0)=LINE
End DoDot:1
+46 ;
+47 SET LINE=$$PAD(9)_"Rated Incomp.: "
SET X=$$YN3(RP(.29),12)
+48 SET LINE=LINE_X
+49 IF X["Y"
Begin DoDot:1
+50 SET LINE=LINE_$$PAD(3)_"Date (CIVIL): "_$$DATENP(RP(.29),2)
+51 SET LINE=LINE_$$PAD(4)_"Date (VA): "_$$DATENP(RP(.29),1)
End DoDot:1
+52 SET LC=LC+1
SET ^TMP($JOB,"BPSELST",LC,0)=LINE
+53 ;
+54 SET RPX=RP(.31)
+55 SET LINE=$$PAD(10)_"Claim Number: "_$SELECT($PIECE(RPX,U,3)]"":$PIECE(RPX,U,3),1:RPU)
+56 SET LC=LC+1
SET ^TMP($JOB,"BPSELST",LC,0)=LINE
+57 ;
+58 SET INST=""
SET INSTP=$PIECE(RP(.31),U,4)
+59 IF INSTP
SET INST=$$EXTERNAL^DILFD(2,.314,"",INSTP)
+60 SET LINE=$$PAD(11)_"Folder Loc.: "_$SELECT(INST]"":INST,INSTP:"INVALID",1:"UNANSWERED")
+61 SET LC=LC+1
SET ^TMP($JOB,"BPSELST",LC,0)=LINE
+62 ; section 2
+63 SET Z=2
SET LINE=$$WW(Z)_$$PAD(3)_"Aid & Attendance: "
+64 SET Z=$$YN3(RP(.362),12)
+65 SET Z1=31
+66 SET LINE=LINE_Z_$$PAD(Z1-$LENGTH(Z))_"Housebound: "
+67 SET Z=$$YN3(RP(.362),13)
+68 SET LINE=LINE_Z
+69 SET LC=LC+1
SET ^TMP($JOB,"BPSELST",LC,0)=LINE
+70 ;
+71 SET LINE=$$PAD(12)_"VA Pension: "
SET Z=$$YN3(RP(.362),14)
+72 SET Z1=28
+73 SET LINE=LINE_Z_$$PAD(Z1-$LENGTH(Z))_"VA Disability: "
SET Z=$$YN3(RP(.3),11)
+74 SET LINE=LINE_Z
+75 SET MBCK=$$MBCK(Z)
+76 SET LC=LC+1
SET ^TMP($JOB,"BPSELST",LC,0)=LINE
+77 ;
+78 SET LINE=$$PAD(4)_"Total Check Amount: "
+79 SET X=$$DISP(RP(.362),20,'MBCK)
+80 SET LINE=LINE_$SELECT(X:"$"_X,1:X)
+81 SET LC=LC+1
SET ^TMP($JOB,"BPSELST",LC,0)=LINE
+82 ;
+83 SET LINE=$$PAD(10)_"GI Insurance: "
+84 SET Z=$$YN3(RP(.362),17)
SET Z1=35
+85 SET LINE=LINE_Z_$$PAD(Z1-$LENGTH(Z))_"Amount: "
+86 SET X=$$DISP(RP(.362),6)
+87 SET LINE=LINE_$SELECT(X:"$"_X,1:X)
+88 SET LC=LC+1
SET ^TMP($JOB,"BPSELST",LC,0)=LINE
+89 ; section 3
+90 SET Z=3
SET LINE=$$WW(Z)
+91 SET RPE=+RP(.36)
SET Z=$$GET1^DIQ(8,+RPE,.01,"I")
SET Z=$SELECT(Z]"":Z,1:RPU)
+92 SET LINE=LINE_$$PAD(2)_"Primary Elig Code: "_Z
+93 SET LC=LC+1
SET ^TMP($JOB,"BPSELST",LC,0)=LINE
+94 ;
+95 ;Agency/Country
+96 SET X=$$EXTERNAL^DILFD(2,.361,"",+$PIECE(RP(.36),U))
+97 SET AAC=$SELECT($DATA(RP(.36)):$SELECT(X]"":+$PIECE(RP(0),U,4),1:""),1:"")
+98 SET AAC(1)=$SELECT('$DATA(RP("VET")):"",RP("VET")'="N":"",AAC=4:"A",AAC=5:"C",1:"")
+99 IF AAC(1)]""
Begin DoDot:1
+100 SET X=$$EXTERNAL^DILFD(2,.309,"",+$PIECE(RP(.3),U,9))
+101 SET LINE=$$PAD(8)_"Agency/Country: "_$SELECT(X]"":X,1:RPU)
+102 SET LC=LC+1
SET ^TMP($JOB,"BPSELST",LC,0)=LINE
End DoDot:1
+103 ;
+104 SET LINE=$$PAD(4)_"Other Elig Code(s): "
+105 SET I1=0
SET SPS=""
SET $PIECE(SPS,SP,25)=""
+106 FOR I=0:0
SET I=$ORDER(^DPT("AEL",DFN,I))
if 'I
QUIT
Begin DoDot:1
+107 SET X=$$EXTERNAL^DILFD(2,.361,"",I)
+108 IF X]""
IF I'=RPE
Begin DoDot:2
+109 SET I1=I1+1
+110 IF I1>1
SET LINE=SPS_X
+111 IF '$TEST
SET LINE=LINE_X
+112 SET LC=LC+1
SET ^TMP($JOB,"BPSELST",LC,0)=LINE
End DoDot:2
End DoDot:1
+113 IF 'I1
Begin DoDot:1
+114 SET LINE=LINE_"NO ADDITIONAL ELIGIBILITIES IDENTIFIED"
+115 SET LC=LC+1
SET ^TMP($JOB,"BPSELST",LC,0)=LINE
End DoDot:1
+116 ;
+117 SET RPX=+$PIECE(RP(.32),U,3)
+118 SET LINE=$$PAD(5)_"Period of Service: "_$SELECT(RPX:$$EXTERNAL^DILFD(2,.323,"",RPX),1:RPU)
+119 SET LC=LC+1
SET ^TMP($JOB,"BPSELST",LC,0)=LINE
+120 ;
+121 ;ODS system on
IF $$ODS(DFN)
Begin DoDot:1
+122 SET RPX=$GET(^DPT(DFN,"ODS"))
+123 SET LINE=$$PAD(6)_"Recalled to Duty: "
+124 SET LINE=LINE_$SELECT($PIECE(RPX,U,2)=1:"FROM NATIONAL GUARDS",$PIECE(RPX,U,2)=2:"FROM RESERVES",$PIECE(RPX,U,2)=0:"NO",1:RPU)
+125 SET LC=LC+1
SET ^TMP($JOB,"BPSELST",LC,0)=LINE
+126 ;
+127 SET LINE=$$PAD(18)_"Rank: "_$SELECT(+$PIECE(RPX,U,3):$$EXTERNAL^DILFD(2,11500.03,"",$PIECE(RPX,U,3)),1:RPU)
+128 SET LC=LC+1
SET ^TMP($JOB,"BPSELST",LC,0)=LINE
End DoDot:1
+129 ;
+130 ;Combat Vet Eligibility
+131 ;SHAD Indicator
SET SHAD=$PIECE(RP(.321),U,15)
+132 SET CV=$$CVEDT(DFN)
+133 IF +$GET(CV)=1
Begin DoDot:1
+134 SET LINE="<3.1> Combat Vet Elig.: "_$SELECT($PIECE(CV,U,3)=1:"ELIGIBLE",$PIECE(CV,U,3)=0:"EXPIRED",1:"")
+135 IF $PIECE($GET(CV),U,2)]""
Begin DoDot:2
+136 SET Y=$$FMTE^XLFDT($PIECE(CV,U,2))
+137 SET LINE=LINE_$$PAD(1)_"End Date: "_Y
End DoDot:2
+138 IF SHAD=1
Begin DoDot:2
+139 SET LINE=LINE_$$PAD(55-$LENGTH(LINE))_"<3.2>Proj 112/SHAD: YES"
End DoDot:2
+140 SET LC=LC+1
SET ^TMP($JOB,"BPSELST",LC,0)=LINE
End DoDot:1
+141 IF (+$GET(CV)'=1)&(SHAD=1)
Begin DoDot:1
+142 SET LINE=$$PAD(55)_"<3.2>Proj 112/SHAD: YES"
+143 SET LC=LC+1
SET ^TMP($JOB,"BPSELST",LC,0)=LINE
End DoDot:1
+144 ;
+145 ;Service connected conditions
+146 ;blank line
SET LINE=""
SET LC=LC+1
SET ^TMP($JOB,"BPSELST",LC,0)=LINE
+147 SET Z=4
SET LINE=$$WW(Z)_" Service Connected Conditions as stated by applicant"
+148 SET LC=LC+1
SET ^TMP($JOB,"BPSELST",LC,0)=LINE
+149 SET X=""
SET $PIECE(X,"-",52)=""
+150 SET SPS=$$PAD(4)
+151 SET LINE=SPS_X
+152 SET LC=LC+1
SET ^TMP($JOB,"BPSELST",LC,0)=LINE
+153 SET LINE=SPS
+154 SET (I,I3,LEN)=0
+155 FOR
SET I=$ORDER(^DPT(DFN,.373,I))
if 'I
QUIT
Begin DoDot:1
+156 NEW I373
+157 SET I373=^DPT(DFN,.373,I,0)
+158 SET I1=$PIECE(I373,U)_" ("_+$PIECE(I373,U,2)_"%), "
+159 SET I3=I
+160 IF $LENGTH(LINE)+$LENGTH(I1)>MAXLEN
Begin DoDot:2
+161 SET LC=LC+1
SET ^TMP($JOB,"BPSELST",LC,0)=LINE
+162 SET LINE=SPS_I1
End DoDot:2
+163 IF '$TEST
Begin DoDot:2
+164 SET LINE=LINE_I1
End DoDot:2
End DoDot:1
+165 IF 'I3
Begin DoDot:1
+166 SET LINE=LINE_"NONE STATED"
+167 SET LC=LC+1
SET ^TMP($JOB,"BPSELST",LC,0)=LINE
End DoDot:1
+168 ;
+169 DO UPDATE^BPSVRX($NAME(^TMP($JOB,"BPSELST")),"","","View Registration Eligibility Status",BPSSNUM)
+170 KILL ^TMP($JOB,"BPSELST")
DGELSTX ;
+1 QUIT
+2 ;
DGELV(RXIEN,FILL,VIEWTYPE,BPSSNUM) ; View Registration Eligibility Verification screen
+1 NEW LC,SP,MAXLEN,DFN,PAT,X,RPTYPE,X1,SPS,RPU,I,RP,Z,RPX,Z1,RPVR,Y,RPNA,STATID,VMETH
+2 NEW EC,EFF,I3,ARR,AI,IVC,VA200,LINE
+3 IF '$DATA(ZTQUEUED)
WRITE !,"Compiling data for View Registration Eligibility Verification ... "
+4 KILL ^TMP($JOB,"BPSELV")
+5 SET LC=0
SET SP=" "
SET MAXLEN=80
+6 SET DFN=+$$RXAPI1^BPSUTIL1(RXIEN,2,"I")
+7 FOR I=.3,.32,.36,.361,"TYPE","VET"
SET RP(I)=$GET(^DPT(DFN,I))
+8 SET PAT=$$SSNNM(DFN)
+9 SET RPTYPE="PATIENT TYPE UNKNOWN"
+10 IF RP("TYPE")]""
Begin DoDot:1
+11 SET RPTYPE=$$GET1^DIQ(391,RP("TYPE"),.01,"I")
End DoDot:1
+12 SET X1=MAXLEN-($LENGTH(PAT)+$LENGTH(RPTYPE))
+13 SET LC=LC+1
SET ^TMP($JOB,"BPSELV",LC,0)=PAT_$$PAD(X1-1)_RPTYPE
+14 SET X=""
SET $PIECE(X,"=",MAXLEN)=""
SET RPU="UNANSWERED"
SET RPNA="NOT APPLICABLE"
+15 SET LC=LC+1
SET ^TMP($JOB,"BPSELV",LC,0)=X
+16 ; section 1
+17 SET Z=1
SET Z1=28
SET LINE=$$WW(Z)_" Eligibility Status: "
+18 SET RPX=RP(.361)
+19 SET X=$PIECE(RPX,U)
SET Z=$SELECT(X']"":"NOT VERIFIED",X="V":"VERIFIED",X="R":"PENDING RE-VERIFICATION",1:"PENDING VERIFICATION")
+20 SET LINE=LINE_Z_$$PAD(Z1-$LENGTH(Z))_"Status Date: "
+21 SET RPVR=$SELECT(X]"":1,1:0)
+22 SET Y=$PIECE(RPX,U,2)
IF Y]""
SET Y=$$FMTE^XLFDT(Y)
+23 SET LINE=LINE_$SELECT(Y]"":Y,RPVR:RPU,1:RPNA)
+24 SET LC=LC+1
SET ^TMP($JOB,"BPSELV",LC,0)=LINE
+25 ;
+26 SET STATID=+$PIECE(RPX,U,6)
+27 SET LINE=$$PAD(5)_"Status Entered By: "
+28 SET VA200=$$GET1^DIQ(200,STATID,.01,"I")
+29 SET LINE=LINE_$SELECT(VA200]"":VA200_" (#"_STATID_")",RPVR:RPU,1:RPNA)
+30 SET LC=LC+1
SET ^TMP($JOB,"BPSELV",LC,0)=LINE
+31 ;
+32 SET LINE=$$PAD(6)_"Interim Response: "
+33 SET Y=$PIECE(RPX,U,4)
IF Y]""
SET Y=$$FMTE^XLFDT(Y)
+34 SET LINE=LINE_$SELECT(Y]"":Y,1:RPU_" (NOT REQUIRED)")
+35 SET LC=LC+1
SET ^TMP($JOB,"BPSELV",LC,0)=LINE
+36 ;
+37 SET SPS=$$PAD(9)
+38 SET VMETH=$PIECE(RPX,U,5)
+39 SET LINE=SPS_"Verif. Method: "_$SELECT(VMETH]"":VMETH,RPVR:RPU,1:RPNA)
+40 SET LC=LC+1
SET ^TMP($JOB,"BPSELV",LC,0)=LINE
+41 ;
+42 ; SPS same as above
+43 SET LINE=SPS_"Verif. Source: "_$SELECT($PIECE(RPX,U,3)="H":"HEC",$PIECE(RPX,U,3)="V":"VISTA",1:"NOT AVAILABLE")
+44 SET LC=LC+1
SET ^TMP($JOB,"BPSELV",LC,0)=LINE
+45 ;
+46 SET Z=2
SET LINE=$$WW(Z)_$$PAD(5)_"Money Verified: "
+47 SET Y=$PIECE(RP(.3),U,6)
IF Y]""
SET Y=$$FMTE^XLFDT(Y)
+48 SET LINE=LINE_$SELECT(Y]"":Y,1:"NOT VERIFIED")
+49 SET LC=LC+1
SET ^TMP($JOB,"BPSELV",LC,0)=LINE
+50 ;
+51 SET Z=3
SET LINE=$$WW(Z)_$$PAD(3)_"Service Verified: "
+52 SET Y=$PIECE(RP(.32),U,2)
IF Y]""
SET Y=$$FMTE^XLFDT(Y)
+53 SET LINE=LINE_$SELECT(Y]"":Y,1:"NOT VERIFIED")
+54 SET LC=LC+1
SET ^TMP($JOB,"BPSELV",LC,0)=LINE
+55 ;
+56 SET SPS=$$PAD(1)
+57 SET Z=4
SET LINE=$$WW(Z)_SPS_"Rated Disabilities: "
+58 SET IVC=$$GET1^DIQ(391,+RP("TYPE"),.02,"I")
+59 IF $PIECE(RP("VET"),U)'="Y"
IF $SELECT(IVC="":1,IVC:0,1:1)
Begin DoDot:1
+60 SET LINE=LINE_RPNA_" - NOT A VETERAN"
+61 SET LC=LC+1
SET ^TMP($JOB,"BPSELV",LC,0)=LINE
+62 DO ELVSTOR($NAME(^TMP($JOB,"BPSELV")),BPSSNUM)
End DoDot:1
QUIT
+63 ; implied else continues here
+64 SET EC=$PIECE(RP(.36),U)
+65 IF EC
SET EC=$$GET1^DIQ(8,EC,.01,"I")
+66 SET LINE=LINE_SPS_"SC%: "_$SELECT(EC="NSC":"",$PIECE(RP(.3),U,2)="":"",1:$PIECE(RP(.3),U,2))
+67 SET EFF=$PIECE(RP(.3),U,14)
+68 IF EFF]""
SET Y=EFF
SET Y=$$FMTE^XLFDT(Y)
SET EFF=Y
+69 SET LINE=LINE_$$PAD(4)_"EFF. DATE OF COMBINED SC%: "_EFF
+70 SET LC=LC+1
SET ^TMP($JOB,"BPSELV",LC,0)=LINE
+71 ;
+72 SET LINE=$$PAD(55)_"Orig"
+73 SET LINE=LINE_$$PAD(70-$LENGTH(LINE))_"Curr"
+74 SET LC=LC+1
SET ^TMP($JOB,"BPSELV",LC,0)=LINE
+75 ;
+76 SET LINE=$$PAD(3)_"Rated Disability"
+77 SET LINE=LINE_$$PAD(46-$LENGTH(LINE))_"Extr"
+78 SET LINE=LINE_$$PAD(55-$LENGTH(LINE))_"Eff Dt"
+79 SET LINE=LINE_$$PAD(70-$LENGTH(LINE))_"Eff Dt"
+80 SET LC=LC+1
SET ^TMP($JOB,"BPSELV",LC,0)=LINE
+81 ;
+82 ;IA #4807
IF '$$RDIS^DGRPDB(DFN,.ARR)
Begin DoDot:1
+83 SET LINE="NONE STATED"
+84 SET LC=LC+1
SET ^TMP($JOB,"BPSELV",LC,0)=LINE
End DoDot:1
+85 IF '$TEST
Begin DoDot:1
+86 SET (I3,AI)=0
+87 FOR
SET AI=$ORDER(ARR(AI))
if 'AI
QUIT
Begin DoDot:2
+88 SET I3=I3+1
+89 NEW CURR,ORIG,BP0,BP1,BP2,BP4,BP5,BP6
+90 IF $GET(ARR(AI))']""
QUIT
+91 SET BP1=$$EXTERNAL^DILFD(2.04,.01,"",+ARR(AI))
+92 IF BP1=""
QUIT
+93 SET BP0=$$EXTERNAL^DILFD(2.04,3,"",$PIECE(ARR(AI),U,3))
+94 SET BP2="("_$SELECT($PIECE(ARR(AI),U,3)=1:$PIECE(ARR(AI),U,2)_"% SC",$PIECE(ARR(AI),U,3)]"":$PIECE(ARR(AI),U,2)_"% NSC",1:"unspec")_")"
+95 SET BP4=$PIECE(ARR(AI),U,4)
SET BP5=$PIECE(ARR(AI),U,5)
SET BP6=$PIECE(ARR(AI),U,6)
+96 IF BP5]""
SET Y=BP5
SET Y=$$FMTE^XLFDT(Y)
SET ORIG=Y
+97 IF BP6]""
SET Y=BP6
SET Y=$$FMTE^XLFDT(Y)
SET CURR=Y
+98 SET LINE=$GET(BP0)_"-"_BP1_BP2
+99 SET LINE=LINE_$$PAD(47-$LENGTH(LINE))_$GET(BP4)
+100 SET LINE=LINE_$$PAD(50-$LENGTH(LINE))_" - "
+101 SET LINE=LINE_$$PAD(53-$LENGTH(LINE))_$GET(ORIG)
+102 SET LINE=LINE_$$PAD(64-$LENGTH(LINE))_" - "
+103 SET LINE=LINE_$$PAD(68-$LENGTH(LINE))_$GET(CURR)
+104 SET LC=LC+1
SET ^TMP($JOB,"BPSELV",LC,0)=LINE
End DoDot:2
+105 IF 'I3
Begin DoDot:2
+106 SET LINE="NONE STATED"
+107 SET LC=LC+1
SET ^TMP($JOB,"BPSELV",LC,0)=LINE
End DoDot:2
End DoDot:1
+108 ;
+109 DO ELVSTOR($NAME(^TMP($JOB,"BPSELV")),BPSSNUM)
DGELVX ;
+1 QUIT
+2 ;
ELVSTOR(ARRNAME,BPSSNUM) ;
+1 DO UPDATE^BPSVRX(ARRNAME,"","","View Registration Eligibility Verification",BPSSNUM)
+2 KILL @ARRNAME
+3 QUIT
+4 ;
SSNNM(DFN) ; SSN and name
+1 NEW X,SSN
+2 SET X=$GET(^DPT(+DFN,0))
+3 SET SSN=$PIECE(X,U,9)
SET SSN=$EXTRACT(SSN,1,3)_"-"_$EXTRACT(SSN,4,5)_"-"_$EXTRACT(SSN,6,10)
+4 SET X=$PIECE(X,U)_"; "_SSN
+5 QUIT X
+6 ;
WW(Z) ;Write number on screens for display (Z=number)
+1 SET Z="<"_Z_">"
+2 QUIT Z
+3 ;
WW1(Z,Z1) ;spacing for screen display (Z=item to print)
+1 NEW Z2
+2 FOR Z2=1:1:(Z1-$LENGTH(Z))
SET Z=Z_" "
+3 QUIT Z
+4 ;
YN(X,RPX,Z1) ;
+1 NEW Z
+2 SET Z=$SELECT($PIECE(RPX,U,X)="Y":"YES",$PIECE(RPX,U,X)="N":"NO",$PIECE(RPX,U,X)="U":"UNKNOWN",1:"UNANSWERED")
+3 QUIT $$WW1(Z,Z1)
+4 ;
YN2(NA,X,RPX,Z1,Z) ;
+1 SET Z=$SELECT(NA:"N/A",$PIECE(RPX,U,X)="Y":"YES",$PIECE(RPX,U,X)="N":"NO",$PIECE(RPX,U,X)="U":"UNKNOWN",1:"UNANSWERED")
+2 QUIT $$WW1(Z,Z1)
+3 ;
YN3(N,P) ; code from YN2^DG1010P0
+1 ; Ext Val of YES/NO given node & piece.
+2 ;IN: N -- Val of Node
+3 ; P -- Piece
+4 ;OUT:[RETURN] -- Ext Val
+5 SET X=$PIECE(N,U,P)
+6 QUIT $SELECT((X="Y"):"YES",(X="N"):"NO",(X="U"):"UNKNOWN",(X=""):"UNANSWERED",("0"[X):"NO",("12"[X):"YES",("3"[X):"UNKNOWN",1:"INVALID")
+7 ;
DATENP(N,P,NA,BL) ;
+1 ; Returns External Value of Date in the Pth '^' piece of 'N'
+2 ; Output is modified by NA & BL as per $$UNK[see above]
+3 ; INPUT:
+4 ; N -- Contents of a node
+5 ; P -- the Pth '^' piece
+6 ; NA,BL -- Optional output modifiers
+7 ; OUTPUT[Returned] -- X
+8 ; OUTPUT[Set] -- DGUNK =1 if NA=1 or X=""
+9 NEW Y,UNK
+10 SET Y=$$DISP(N,P,+$GET(NA),$GET(BL),.UNK)
+11 IF 'UNK
SET Y=$$FMTE^XLFDT(Y)
+12 QUIT Y
+13 ;
DISP(N,P,NA,BL,UNK) ;
+1 ; Returns the Pth '^' piece of 'N'
+2 ; Output is modified by NA & BL as per $$UNK[see above]
+3 ; INPUT: N -- Contents of a node
+4 ; P -- the Pth '^' piece
+5 ; NA,BL -- Optional output modifiers
+6 ; OUTPUT[Returned] -- X
+7 ; OUTPUT[Set] -- DGUNK =1 if NA=1 or X=""
+8 NEW X
+9 SET X=$PIECE($GET(N),U,P)
+10 SET UNK=$SELECT($GET(NA):1,(X]""):0,1:1)
+11 QUIT $SELECT(($GET(NA)):"NOT APPLICABLE",(X]""):X,($GET(BL)):"",1:"UNANSWERED")
+12 ;
MBCK(X) ;flag for any MB Y/N fields = yes
+1 NEW MBCK
+2 SET MBCK=$SELECT($GET(MBCK):1,(X="Y"):1,1:0)
+3 QUIT MBCK
+4 ;
CVEDT(DFN,TDT) ;Provide Combat Vet Eligibility End Date, if eligible
+1 ;Supported DBIA #4156
+2 ;Input: DFN - Patient file IEN
+3 ; TDT - Treatment date (optional),
+4 ; DT is default
+5 ;Output :RESULT=(1,0,-1)^End Date (if populated, otherwise null)^CV
+6 ; Eligible on DGDT(1,0)^is patient eligible on input date?
+7 ; (piece 1) 1 - qualifies as a CV
+8 ; 0 - does not qualify as a CV
+9 ; -1 - bad DFN or date
+10 ; (piece 3) 1 - vet was eligible on date specified (or DT)
+11 ; 0 - vet was not eligible on date specified (or DT)
+12 ;
+13 NEW RESULT
+14 SET RESULT=""
+15 IF $GET(DFN)=""
QUIT -1
+16 IF '$DATA(^DPT(DFN))
QUIT -1
+17 ;if time sent in, drop time
+18 IF $GET(TDT)']""
SET TDT=DT
+19 IF TDT?7N1"."1.6N
SET TDT=$EXTRACT(TDT,1,7)
+20 IF TDT'?7N
QUIT -1
+21 SET RESULT=$$GET1^DIQ(2,DFN_",",.5295,"I")
+22 IF $GET(RESULT)']""
QUIT 0
+23 ; if treatment date is earlier or equal to end date, veteran is eligible
+24 SET RESULT=$SELECT(TDT'>RESULT:RESULT_"^1",1:RESULT_"^0")
+25 SET RESULT=$SELECT($GET(RESULT):1_U_RESULT,1:0)
+26 QUIT RESULT
+27 ;
ODS(DFN) ;ODS software check
+1 NEW ODS,POS
+2 SET ODS=$$GET1^DIQ(11500.5,1,.02,"I")
+3 IF 'ODS
QUIT ODS
+4 SET ODS=0
+5 IF $DATA(^DPT(DFN,.32))
Begin DoDot:1
+6 SET POS=$$GET1^DIQ(2,DFN,.323,"I")
+7 if POS=6
SET ODS=1
End DoDot:1
+8 QUIT ODS
+9 ;
PAD(LEN) ; space padding function
+1 ; Input:
+2 ; LEN (r) --> padding length
+3 ; Output:
+4 ; A string of space characters
+5 ;
+6 NEW SPS,SP
+7 SET SP=$CHAR(32)
+8 SET SPS=""
SET $PIECE(SPS,SP,LEN+1)=""
+9 QUIT SPS
+10 ;
