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

DGRPDB.m

Go to the documentation of this file.
  1. DGRPDB ;ALB/AAS,JAN,ERC,PHH,HM,JAM - VIEW ONLY SCREEN TO DETERMINE BILLING ELIGIBILITY ;24 Dec 2018 1:45 PM
  1. ;;5.3;Registration;**26,50,358,570,631,709,713,749,972,1064,1104**;Aug 13, 1993;Build 59
  1. ; Reference to $$ASC^PXCOMPACT in ICR #7327
  1. ;
  1. % S:'$D(DGQUIT) DGQUIT=0
  1. G:DGQUIT END S DIC="^DPT(",DIC(0)="AEQMN" D ^DIC G:+Y<1 END S DFN=+Y D EN
  1. G %
  1. ;
  1. EN ;entry with DFN defined.
  1. Q:'$D(DFN) D HOME^%ZIS,2^VADPT,HDR
  1. ;jam; DG*5.3*1064
  1. I $$INDSTATUS^DGENELA2(DFN) W !,$$EZBLD^DIALOG(261133)
  1. D MT,AOIR,ELIG,DIS,MOH ;added MOH DG*5.3*972
  1. N DGINS
  1. I $$INSUR^IBBAPI(DFN,"","AR",.DGINS,1)
  1. S C="",C=$O(DGINS("IBBAPI","INSUR",C),-1),C=+C+6
  1. D:($Y>(IOSL-C)) PAUSE,HDR:'DGQUIT Q:DGQUIT D INS,PAUSE
  1. Q
  1. ;
  1. ELIG ;eligibility code(s)
  1. W !,"Acute Suicidal Crisis: ",$$ASC^PXCOMPACT(DFN)
  1. W !," Primary Elig. Code: ",$P(VAEL(1),"^",2)," -- ",$S(VAEL(8)']"":"NOT VERIFIED",1:$P(VAEL(8),"^",2))
  1. I VAEL(8)]"" S Y=$S($D(^DPT(DFN,.361)):$P(^(.361),"^",2),1:"") W " " D DT^DIQ
  1. W !,"Other Elig. Code(s): " I $D(VAEL(1))>9 S I1=0 F I=0:0 S I=$O(VAEL(1,I)) Q:'I S I1=I1+1 W:I1>1 !?21 W $P(VAEL(1,I),"^",2)
  1. E W "NO ADDITIONAL ELIGIBILITIES IDENTIFIED"
  1. Q
  1. ;
  1. ;display medal of honor information DG*5.3*972 HM
  1. MOH ;medal of honor
  1. N DGMOHADT,DGMOHSDT,DGMOHCED
  1. I $P($G(^DPT(DFN,.54)),"^")="Y" D
  1. .W !," Medal of Honor: YES"
  1. .N DGMOHADT,DGMOHEDT,DGMOHSDT
  1. .S DGMOHADT=$P($G(^DPT(DFN,.54)),"^",2),DGMOHSDT=$P($G(^DPT(DFN,.54)),"^",3),DGMOHEDT=$P($G(^DPT(DFN,.54)),"^",4) ;get MOH AWARD DATE,MOH STATUS DATE, & MOH COPAYMENT EXEMPTION DATE
  1. .I DGMOHADT="" S DGMOHADT="UNKNOWN",DGMOHEDT="Needs Determination" ;Display text when MOH AWARD DATE empty
  1. .W ?35,"MOH Status Date: "_$$FMTE^XLFDT(DGMOHSDT,"5DZ") ;format MOH STATUS DATE
  1. .W !," MOH Award Date: "_$$FMTE^XLFDT(DGMOHADT,"5DZ") ;format MOH AWARD DATE
  1. .W ?35,"MOH Copay Exemption Date: "_$$FMTE^XLFDT(DGMOHEDT,"5DZ") ;format MOH COPAYMENT EXEMPTION DATE
  1. I $P($G(^DPT(DFN,.54)),"^")="N" D ;if MOH indicator is N
  1. .N DGMOHSDT S DGMOHSDT=$P($G(^DPT(DFN,.54)),"^",3) ;set status date
  1. .W !," Medal of Honor: NO"
  1. .W ?35,"MOH Status Date: "_$$FMTE^XLFDT(DGMOHSDT,"5DZ") ;format MOH STATUS DATE
  1. .W !," MOH Award Date: "
  1. .W ?35,"MOH Copay Exemption Date: "
  1. I $P($G(^DPT(DFN,.54)),"^")="" D ;if MOH indicator is null
  1. .W !," Medal of Honor: "
  1. .W ?35,"MOH Status Date: "
  1. .W !," MOH Award Date: "
  1. .W ?35,"MOH Copay Exemption Date: "
  1. Q
  1. DIS ;rated disabilities - Integration Agreement #700
  1. ;
  1. ; This is called from the FEE and MCCR package!!!
  1. ;
  1. ; Input: DFN as IEN of PATIENT file
  1. ; VAEL array (if no passed, it is set) of eligibility info
  1. ;
  1. I '$D(VAEL) D ELIG^VADPT S DGKVAR=1
  1. W:'+VAEL(3) !!," Service Connected: NO" W:+VAEL(3) !!," SC Percent: ",$P(VAEL(3),"^",2)_"%"
  1. N DGQUIT
  1. W !," Rated Disabilities: " I 'VAEL(4),$S('$D(^DG(391,+VAEL(6),0)):1,$P(^(0),"^",2):0,1:1) W "NOT A VETERAN" G DISQ
  1. S I3=0 F I=0:0 S I=$O(^DPT(DFN,.372,I)) Q:'I!($G(DGQUIT)=1) D
  1. . S I1=^(I,0),I2=$S($D(^DIC(31,+I1,0)):$P(^(0),"^",1)_" ("_+$P(I1,"^",2)_"%-"_$S($P(I1,"^",3):"SC",$P(I1,"^",3)']"":"not specified",1:"NSC")_")",1:""),I3=I3+1
  1. . I $Y>(IOSL-3) D PAUSE I $G(DGQUIT)=0 W @IOF
  1. . I $G(DGQUIT)=1 Q
  1. . W:I3>1 !?21 W I2
  1. W:'I3 "NONE STATED"
  1. DISQ I $D(DGKVAR) D KVAR^VADPT K DGKVAR
  1. K I,I1,I2,I3
  1. Q
  1. ;
  1. INS ;insurance information
  1. ;
  1. ; This is called form the FEE package!!!
  1. ;
  1. ; Input: DFN as IEN of PATIENT file
  1. ; DGINSDT as date to compute insurance flag as of (default DT)
  1. ;
  1. Q:'$D(DFN)
  1. W !!," Health Insurance: "
  1. S Z=$$INSUR^IBBAPI(DFN,$S($D(DGINSDT):DGINSDT,1:DT))
  1. W $S(Z:"YES",1:"NO")
  1. D DISP^DGIBDSP
  1. INSQ K I,I1,DGX,Z
  1. Q
  1. ;
  1. IN ; Old code
  1. Q
  1. ;
  1. AOIR ;Agent Orange/ionizing radiation/Camp Lejeune
  1. N DGEC,NTA,DGCL
  1. S DGX=$S($D(^DPT(DFN,.321)):^(.321),1:"")
  1. F I=2,3 S X=$P(DGX,"^",I) W:I=2 !," A/O Exp.: " W:I=3 "ION Rad.: " W $S(X="Y":"YES",X="N":"NO",X="U":"UNKNOWN",1:"NOT ANSWERED")," "
  1. S X=$G(^DPT(DFN,.38)),X1=$P(X,"^",1) W "Medicaid Elig: ",$S(X1="":"NOT ANSWERED",'X1:"NO",1:"YES") I ($X+15)'>IOM W " - " S Y=$P(X,"^",2) D D^DIQ W $P(Y,"@")
  1. S DGEC=$S($D(^DPT(DFN,.322)):^DPT(DFN,.322),1:"")
  1. S X=$P(DGEC,U,13) W !," Env Contam.: " W $S(X="Y":"YES",X="N":"NO",X="U":"UNKNOWN",1:"NOT ANSWERED")," "
  1. S NTA=$S($$GETCUR^DGNTAPI(DFN,"DGNTARR")>0:DGNTARR("INTRP"),1:"")
  1. K DGNTARR
  1. W "N/T Radium: " W $S(NTA'="":NTA,1:"NOT ANSWERED")
  1. ;DG*5.3*972 HM - Camp Lejeune will always be on next line
  1. S DGCL=$S($D(^DPT(DFN,.3217)):^DPT(DFN,.3217),1:""),X=$P(DGCL,"^",1) W !," Camp Lejeune: " W $S(X="Y":"YES",X="N":"NO",1:"NOT ANSWERED")
  1. Q
  1. ;
  1. PAUSE F J=1:1 Q:($Y>(IOSL-3)) W !
  1. S DGX1="" I $E(IOST,1,2)["C-" N DIR S DIR(0)="E" D ^DIR S DGQUIT='Y
  1. Q
  1. ;
  1. HDR ;Screen Header
  1. W @IOF I $P(VAEL(6),"^",2)]"" S DGTYPE=$P(VAEL(6),"^",2)
  1. W $P(VADM(1),"^",1),?32,VA("PID"),?47,$P(VADM(3),"^",2) S X=$S($D(DGTYPE):$P(DGTYPE,"^",1),1:"PATIENT TYPE UNKNOWN"),X1=79-$L(X) W ?X1,X
  1. S X="",$P(X,"=",80)="" W !,X Q
  1. Q
  1. ;
  1. MT I '$O(^DGMT(408.31,"AD",1,DFN,0)) W !," Means Test Status: NOT IN MEANS TEST FILE" Q
  1. ;if patient is on a DOM ward, don't display Means Test required message
  1. D DOM^DGMTR D:'$G(DGDOM) DIS^DGMTU(DFN) K DGDOM
  1. Q
  1. ;
  1. END D KVAR^VADPT
  1. K A,C,I,I1,I2,I3,J,DIC,DIR,DFN,DGA1,DGMT,DGMTL,DGMTLA,DGX,DGX1,DGT,DGTYPE,DGQUIT,DGMTLL,X,X1,VAROOT,VA,Y,Z
  1. Q
  1. ;
  1. RDIS(DGDFN,DGARR) ;API to return all Rated Disabilities from the
  1. ;Patient file for a patient using an array. Returned in descending Service Connected percent.
  1. ;
  1. ; Integration Agreement #4807
  1. ;
  1. ;Input DGDFN - IEN of patient file (required)
  1. ;Input/Output DGARR - name of array for returned disability info (required)
  1. ; piece 1 - Disability IEN (in file 31)
  1. ; piece 2 - Disability %
  1. ; piece 3 - SC? (1,0)
  1. ; piece 4 - extremity affected
  1. ; piece 5 - original effective date
  1. ; piece 6 - current effective date
  1. ;Output 1=successful and array returned with data
  1. ; 0=unsuccessful and no array
  1. ;
  1. N DGARR1,DGC,DGCC,DGERR,DGNODE,DGCT,DGE,DGEE
  1. K DGW,DGARR
  1. I $G(DGDFN)']"" Q 0
  1. I '$D(^DPT(DGDFN,0)) Q 0
  1. D GETS^DIQ(2,DGDFN,".3721*","I","DGARR1","DGERR")
  1. I $D(DGERR) Q 0
  1. S DGCC=0
  1. S DGCC=$O(^DPT(DGDFN,.372,DGCC))
  1. I 'DGCC Q 0
  1. S DGC=""
  1. F S DGC=$O(DGARR1(2.04,DGC)) Q:DGC']"" D
  1. . S DGNODE=DGC
  1. . S DGARR(DGC)=DGARR1(2.04,DGNODE,.01,"I")_"^"_DGARR1(2.04,DGNODE,2,"I")_"^"_DGARR1(2.04,DGNODE,3,"I")_"^"_DGARR1(2.04,DGNODE,4,"I")_"^"_DGARR1(2.04,DGNODE,5,"I")_"^"_DGARR1(2.04,DGNODE,6,"I")
  1. S DGE=""
  1. F S DGE=$O(DGARR(DGE)) Q:'DGE D
  1. . I $P(DGARR(DGE),U,2)="" S $P(DGARR(DGE),U,2)=0
  1. . S DGW($P(DGARR(DGE),U,2),$P(DGE,",",1))=DGARR(DGE)
  1. S DGE="",DGCT=1
  1. K DGARR
  1. F S DGE=$O(DGW(DGE),-1) Q:DGE']"" D
  1. . F DGEE=0:0 S DGEE=$O(DGW(DGE,DGEE)) Q:DGEE'>0 D
  1. . . S DGARR(DGCT)=DGW(DGE,DGEE) S DGCT=DGCT+1
  1. K DGW
  1. Q 1
  1. ;