IB20PT87 ;ALB/CPM - EXPORT ROUTINE 'DGRPDB' ; 14-FEB-94
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;
DGRPDB ;ALB/AAS - VIEW ONLY SCREEN TO DETERMINE BILLING ELIGIBILITY ; 20 DEC 90 1:30 pm
;;5.3;Registration;**26**;Aug 13, 1993
;
% S:'$D(DGQUIT) DGQUIT=0
G:DGQUIT END S DIC="^DPT(",DIC(0)="AEQMN" D ^DIC G:+Y<1 END S DFN=+Y D EN
G %
;
EN ;entry with DFN defined.
Q:'$D(DFN) D HOME^%ZIS,2^VADPT,HDR
D MT,AOIR,ELIG,DIS
S C=$S($D(^DPT(DFN,.312,0)):$P(^(0),"^",4),1:0),C=C+6
D:($Y>(IOSL-C)) PAUSE,HDR:'DGQUIT Q:DGQUIT D INS,PAUSE
Q
;
ELIG ;eligibility code(s)
W !!," Primary Elig. Code: ",$P(VAEL(1),"^",2)," -- ",$S(VAEL(8)']"":"NOT VERIFIED",1:$P(VAEL(8),"^",2))
I VAEL(8)]"" S Y=$S($D(^DPT(DFN,.361)):$P(^(.361),"^",2),1:"") W " " D DT^DIQ
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)
E W "NO ADDITIONAL ELIGIBILITIES IDENTIFIED"
Q
;
DIS ;rated disabilities
;
; This is called from the FEE and MCCR package!!!
;
; Input: DFN as IEN of PATIENT file
; VAEL array (if no passed, it is set) of eligibility info
;
I '$D(VAEL) D ELIG^VADPT S DGKVAR=1
W:'+VAEL(3) !!," Service Connected: NO" W:+VAEL(3) !!," SC Percent: ",$P(VAEL(3),"^",2)_"%"
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
S I3=0 F I=0:0 S I=$O(^DPT(DFN,.372,I)) Q:'I 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 W:I3>1 !?21 W I2
W:'I3 "NONE STATED"
DISQ I $D(DGKVAR) D KVAR^VADPT K DGKVAR
K I,I1,I2,I3
Q
;
INS ;insurance information
;
; This is called form the FEE package!!!
;
; Input: DFN as IEN of PATIENT file
;
Q:'$D(DFN)
W !!," Health Insurance: " S Z=$S($D(^DPT(DFN,.31)):$P(^(.31),"^",11),1:"") W $S(Z="Y":"YES",Z="N":"NO",Z="U":"UNKNOWN",1:"NOT ANSWERED")
D DISP^IBCNSP2
INSQ K I,I1,DGX,Z
Q
;
IN W !?3,$S($D(^DIC(36,+$P(DGX,"^",1),0)):$E($P(^(0),"^",1),1,25),1:"UNKNOWN"),?30,$S($P(DGX,"^",2)]"":$P(DGX,"^",2),1:"UNKNOWN"),?52,$S($P(DGX,"^",3)]"":$P(DGX,"^",3),1:"UNKNOWN")
W ?71,$S($P(DGX,"^",6)="v":"APPLICANT",$P(DGX,"^",6)="s":"SPOUSE",$P(DGX,"^",6)="o":"OTHER",1:"UNKNOWN")
Q
;
AOIR ;Agent Orange/ionizing radiation
S DGX=$S($D(^DPT(DFN,.321)):^(.321),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")," "
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,"@")
Q
;
PAUSE F J=1:1 Q:($Y>(IOSL-3)) W !
S DGX1="" I $E(IOST,1,2)["C-" N DIR S DIR(0)="E" D ^DIR S DGQUIT='Y
Q
;
HDR ;Screen Header
W @IOF I $P(VAEL(6),"^",2)]"" S DGTYPE=$P(VAEL(6),"^",2)
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
S X="",$P(X,"=",80)="" W !,X Q
Q
;
MT I '$O(^DGMT(408.31,"AD",1,DFN,0)) W !," Means Test Status: NOT IN MEANS TEST FILE" Q
D DIS^DGMTU(DFN)
Q
;
END D KVAR^VADPT
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
Q
IB20PT87 ;ALB/CPM - EXPORT ROUTINE 'DGRPDB' ; 14-FEB-94
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;
DGRPDB ;ALB/AAS - VIEW ONLY SCREEN TO DETERMINE BILLING ELIGIBILITY ; 20 DEC 90 1:30 pm
+1 ;;5.3;Registration;**26**;Aug 13, 1993
+2 ;
% IF '$DATA(DGQUIT)
SET DGQUIT=0
+1 IF DGQUIT
GOTO END
SET DIC="^DPT("
SET DIC(0)="AEQMN"
DO ^DIC
IF +Y<1
GOTO END
SET DFN=+Y
DO EN
+2 GOTO %
+3 ;
EN ;entry with DFN defined.
+1 IF '$DATA(DFN)
QUIT
DO HOME^%ZIS
DO 2^VADPT
DO HDR
+2 DO MT
DO AOIR
DO ELIG
DO DIS
+3 SET C=$SELECT($DATA(^DPT(DFN,.312,0)):$PIECE(^(0),"^",4),1:0)
SET C=C+6
+4 IF ($Y>(IOSL-C))
DO PAUSE
IF 'DGQUIT
DO HDR
IF DGQUIT
QUIT
DO INS
DO PAUSE
+5 QUIT
+6 ;
ELIG ;eligibility code(s)
+1 WRITE !!," Primary Elig. Code: ",$PIECE(VAEL(1),"^",2)," -- ",$SELECT(VAEL(8)']"":"NOT VERIFIED",1:$PIECE(VAEL(8),"^",2))
+2 IF VAEL(8)]""
SET Y=$SELECT($DATA(^DPT(DFN,.361)):$PIECE(^(.361),"^",2),1:"")
WRITE " "
DO DT^DIQ
+3 WRITE !,"Other Elig. Code(s): "
IF $DATA(VAEL(1))>9
SET I1=0
FOR I=0:0
SET I=$ORDER(VAEL(1,I))
IF 'I
QUIT
SET I1=I1+1
IF I1>1
WRITE !?21
WRITE $PIECE(VAEL(1,I),"^",2)
+4 IF '$TEST
WRITE "NO ADDITIONAL ELIGIBILITIES IDENTIFIED"
+5 QUIT
+6 ;
DIS ;rated disabilities
+1 ;
+2 ; This is called from the FEE and MCCR package!!!
+3 ;
+4 ; Input: DFN as IEN of PATIENT file
+5 ; VAEL array (if no passed, it is set) of eligibility info
+6 ;
+7 IF '$DATA(VAEL)
DO ELIG^VADPT
SET DGKVAR=1
+8 IF '+VAEL(3)
WRITE !!," Service Connected: NO"
IF +VAEL(3)
WRITE !!," SC Percent: ",$PIECE(VAEL(3),"^",2)_"%"
+9 WRITE !," Rated Disabilities: "
IF 'VAEL(4)
IF $SELECT('$DATA(^DG(391,+VAEL(6),0)):1,$PIECE(^(0),"^",2):0,1:1)
WRITE "NOT A VETERAN"
GOTO DISQ
+10 SET I3=0
FOR I=0:0
SET I=$ORDER(^DPT(DFN,.372,I))
IF 'I
QUIT
SET I1=^(I,0)
SET I2=$SELECT($DATA(^DIC(31,+I1,0)):$PIECE(^(0),"^",1)_" ("_+$PIECE(I1,"^",2)_"%-"_$SELECT($PIECE(I1,"^",3):"SC",$PIECE(I1,"^",3)']"":"not specified",1:"NSC")_")",1:"")
SET I3=I3+1
IF I3>1
WRITE !?21
WRITE I2
+11 IF 'I3
WRITE "NONE STATED"
DISQ IF $DATA(DGKVAR)
DO KVAR^VADPT
KILL DGKVAR
+1 KILL I,I1,I2,I3
+2 QUIT
+3 ;
INS ;insurance information
+1 ;
+2 ; This is called form the FEE package!!!
+3 ;
+4 ; Input: DFN as IEN of PATIENT file
+5 ;
+6 IF '$DATA(DFN)
QUIT
+7 WRITE !!," Health Insurance: "
SET Z=$SELECT($DATA(^DPT(DFN,.31)):$PIECE(^(.31),"^",11),1:"")
WRITE $SELECT(Z="Y":"YES",Z="N":"NO",Z="U":"UNKNOWN",1:"NOT ANSWERED")
+8 DO DISP^IBCNSP2
INSQ KILL I,I1,DGX,Z
+1 QUIT
+2 ;
IN WRITE !?3,$SELECT($DATA(^DIC(36,+$PIECE(DGX,"^",1),0)):$EXTRACT($PIECE(^(0),"^",1),1,25),1:"UNKNOWN"),?30,$SELECT($PIECE(DGX,"^",2)]"":$PIECE(DGX,"^",2),1:"UNKNOWN"),?52,$SELECT($PIECE(DGX,"^",3)]"":$PIECE(DGX,"^",3),1:"UNKNOWN")
+1 WRITE ?71,$SELECT($PIECE(DGX,"^",6)="v":"APPLICANT",$PIECE(DGX,"^",6)="s":"SPOUSE",$PIECE(DGX,"^",6)="o":"OTHER",1:"UNKNOWN")
+2 QUIT
+3 ;
AOIR ;Agent Orange/ionizing radiation
+1 SET DGX=$SELECT($DATA(^DPT(DFN,.321)):^(.321),1:"")
+2 FOR I=2,3
SET X=$PIECE(DGX,"^",I)
IF I=2
WRITE !," A/O Exp.: "
IF I=3
WRITE "ION Rad.: "
WRITE $SELECT(X="Y":"YES",X="N":"NO",X="U":"UNKNOWN",1:"NOT ANSWERED")," "
+3 SET X=$GET(^DPT(DFN,.38))
SET X1=$PIECE(X,"^",1)
WRITE "Medicaid Elig: ",$SELECT(X1="":"NOT ANSWERED",'X1:"NO",1:"YES")
IF ($X+15)'>IOM
WRITE " - "
SET Y=$PIECE(X,"^",2)
DO D^DIQ
WRITE $PIECE(Y,"@")
+4 QUIT
+5 ;
PAUSE FOR J=1:1
IF ($Y>(IOSL-3))
QUIT
WRITE !
+1 SET DGX1=""
IF $EXTRACT(IOST,1,2)["C-"
NEW DIR
SET DIR(0)="E"
DO ^DIR
SET DGQUIT='Y
+2 QUIT
+3 ;
HDR ;Screen Header
+1 WRITE @IOF
IF $PIECE(VAEL(6),"^",2)]""
SET DGTYPE=$PIECE(VAEL(6),"^",2)
+2 WRITE $PIECE(VADM(1),"^",1),?32,VA("PID"),?47,$PIECE(VADM(3),"^",2)
SET X=$SELECT($DATA(DGTYPE):$PIECE(DGTYPE,"^",1),1:"PATIENT TYPE UNKNOWN")
SET X1=79-$LENGTH(X)
WRITE ?X1,X
+3 SET X=""
SET $PIECE(X,"=",80)=""
WRITE !,X
QUIT
+4 QUIT
+5 ;
MT IF '$ORDER(^DGMT(408.31,"AD",1,DFN,0))
WRITE !," Means Test Status: NOT IN MEANS TEST FILE"
QUIT
+1 DO DIS^DGMTU(DFN)
+2 QUIT
+3 ;
END DO KVAR^VADPT
+1 KILL 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
+2 QUIT
