DGCRNS ;ALB/AAS - IS INSURANCE ACTIVE ; 22-JULY-91
;;5.3;Registration;**1015**;Aug 13, 1993;Build 21
;
;Input - DFN = patient
; - DGCRINDT = (optional) date to check ins active for or today if not defined
; - DGCROUTP = (optional) 1 if want active insurance returned in DGCRDD(insurance company)=node in patient file
; - = 2 if want all ins returned
;
;Output - DGCRINS = 1 if has active ins., 0 if no active ins.
; - DGCRDD() = internal node in patient file of valid ins.
; - DGCRDDI() = internal node in patient file of invalid ins.
;
% N J,X S DGCRINS=0 K DGCRDD,DGCRDDI
S J=0 F S J=$O(^DPT(DFN,.312,J)) Q:'J I $D(^DPT(DFN,.312,J,0)) S X=^(0) D CHK
Q
;
CHK ;
;Input - DGCRI = entry in insurance multiple
;
S Z=$S($D(DGCRINDT):DGCRINDT,1:DT),Z1=$S($D(DGCROUTP):DGCROUTP,1:0)
G:'$D(^DIC(36,+X,0)) CHKQ S X1=^(0) ;insurance company entry doesn't exist
I $P(X,"^",8) G:Z<$P(X,"^",8) CHKQ ;effective date later than care
I $P(X,"^",4) G:Z>$P(X,"^",4) CHKQ ;care after expiration date
G:$P(X1,"^",5) CHKQ ;insurance company inactive
G:$P(X1,"^",2)="N" CHKQ ;insurance company will not reimburse
S DGCRINS=1 I Z1 S DGCRDD(+X)=X
CHKQ S:Z1=2&('$D(DGCRDD(+X))) DGCRDDI(+X)=X
K X,X1,Z,Z1 Q
;
DD ; - called from input transform and x-refs for field 101,102,103
; - input requires da=internal entry number in 399
; - outputs dgcrdd(ins co.) array
N DFN S DFN=$P(^DGCR(399,DA,0),"^",2),DGCROUTP=1,DGCRINDT=$S(+$G(^DGCR(399,DA,"U")):+$G(^("U")),1:DT)
D %
DDQ K DGCROUTP,DGCRINDT Q
;
;
DISP ; -Display all insurance company information
; -input DFN
;
Q:'$D(DFN) D:'$D(IOF) HOME^%ZIS
S DGCROUTP=2 D DGCRNS
;
D HDR
I '$D(DGCRDD),'$D(DGCRDDI) W !,"No Insurance Information" G DISPQ
;
S X="" F S X=$O(DGCRDD(X)) Q:X="" S IBINS=DGCRDD(X) D D1 ;active insurance
S X="" F S X=$O(DGCRDDI(X)) Q:X="" S IBINS=DGCRDDI(X) D D1 ;inactive ins
;
DISPQ K DGCRDD,DGCRDDI,DGCRX
Q
;
HDR W !?4,"Insurance Co.",?22,"Policy #",?40,"Group",?52,"Holder",?60,"Effective",?70,"Expires" S X="",$P(X,"=",IOM-4)="" W !?4,X
Q
;
;
D1 N X Q:'$D(IBINS)
W !?4,$S($D(^DIC(36,+IBINS,0)):$E($P(^(0),"^",1),1,16),1:"UNKNOWN")
W ?22,$E($P(IBINS,"^",2),1,16),?40,$E($S($P(IBINS,"^",15)'="":$P(IBINS,"^",15),1:$P(IBINS,"^",3)),1,10)
S X=$P(IBINS,"^",6) W ?52,$S(X="v":"SELF",X="s":"SPOUSE",1:"OTHER")
W ?60,$$DAT1^IBOUTL($P(IBINS,"^",8)),?70,$$DAT1^IBOUTL($P(IBINS,"^",4))
Q
DGCRNS ;ALB/AAS - IS INSURANCE ACTIVE ; 22-JULY-91
+1 ;;5.3;Registration;**1015**;Aug 13, 1993;Build 21
+2 ;
+3 ;Input - DFN = patient
+4 ; - DGCRINDT = (optional) date to check ins active for or today if not defined
+5 ; - DGCROUTP = (optional) 1 if want active insurance returned in DGCRDD(insurance company)=node in patient file
+6 ; - = 2 if want all ins returned
+7 ;
+8 ;Output - DGCRINS = 1 if has active ins., 0 if no active ins.
+9 ; - DGCRDD() = internal node in patient file of valid ins.
+10 ; - DGCRDDI() = internal node in patient file of invalid ins.
+11 ;
% NEW J,X
SET DGCRINS=0
KILL DGCRDD,DGCRDDI
+1 SET J=0
FOR
SET J=$ORDER(^DPT(DFN,.312,J))
IF 'J
QUIT
IF $DATA(^DPT(DFN,.312,J,0))
SET X=^(0)
DO CHK
+2 QUIT
+3 ;
CHK ;
+1 ;Input - DGCRI = entry in insurance multiple
+2 ;
+3 SET Z=$SELECT($DATA(DGCRINDT):DGCRINDT,1:DT)
SET Z1=$SELECT($DATA(DGCROUTP):DGCROUTP,1:0)
+4 ;insurance company entry doesn't exist
IF '$DATA(^DIC(36,+X,0))
GOTO CHKQ
SET X1=^(0)
+5 ;effective date later than care
IF $PIECE(X,"^",8)
IF Z<$PIECE(X,"^",8)
GOTO CHKQ
+6 ;care after expiration date
IF $PIECE(X,"^",4)
IF Z>$PIECE(X,"^",4)
GOTO CHKQ
+7 ;insurance company inactive
IF $PIECE(X1,"^",5)
GOTO CHKQ
+8 ;insurance company will not reimburse
IF $PIECE(X1,"^",2)="N"
GOTO CHKQ
+9 SET DGCRINS=1
IF Z1
SET DGCRDD(+X)=X
CHKQ IF Z1=2&('$DATA(DGCRDD(+X)))
SET DGCRDDI(+X)=X
+1 KILL X,X1,Z,Z1
QUIT
+2 ;
DD ; - called from input transform and x-refs for field 101,102,103
+1 ; - input requires da=internal entry number in 399
+2 ; - outputs dgcrdd(ins co.) array
+3 NEW DFN
SET DFN=$PIECE(^DGCR(399,DA,0),"^",2)
SET DGCROUTP=1
SET DGCRINDT=$SELECT(+$GET(^DGCR(399,DA,"U")):+$GET(^("U")),1:DT)
+4 DO %
DDQ KILL DGCROUTP,DGCRINDT
QUIT
+1 ;
+2 ;
DISP ; -Display all insurance company information
+1 ; -input DFN
+2 ;
+3 IF '$DATA(DFN)
QUIT
IF '$DATA(IOF)
DO HOME^%ZIS
+4 SET DGCROUTP=2
DO DGCRNS
+5 ;
+6 DO HDR
+7 IF '$DATA(DGCRDD)
IF '$DATA(DGCRDDI)
WRITE !,"No Insurance Information"
GOTO DISPQ
+8 ;
+9 ;active insurance
SET X=""
FOR
SET X=$ORDER(DGCRDD(X))
IF X=""
QUIT
SET IBINS=DGCRDD(X)
DO D1
+10 ;inactive ins
SET X=""
FOR
SET X=$ORDER(DGCRDDI(X))
IF X=""
QUIT
SET IBINS=DGCRDDI(X)
DO D1
+11 ;
DISPQ KILL DGCRDD,DGCRDDI,DGCRX
+1 QUIT
+2 ;
HDR WRITE !?4,"Insurance Co.",?22,"Policy #",?40,"Group",?52,"Holder",?60,"Effective",?70,"Expires"
SET X=""
SET $PIECE(X,"=",IOM-4)=""
WRITE !?4,X
+1 QUIT
+2 ;
+3 ;
D1 NEW X
IF '$DATA(IBINS)
QUIT
+1 WRITE !?4,$SELECT($DATA(^DIC(36,+IBINS,0)):$EXTRACT($PIECE(^(0),"^",1),1,16),1:"UNKNOWN")
+2 WRITE ?22,$EXTRACT($PIECE(IBINS,"^",2),1,16),?40,$EXTRACT($SELECT($PIECE(IBINS,"^",15)'="":$PIECE(IBINS,"^",15),1:$PIECE(IBINS,"^",3)),1,10)
+3 SET X=$PIECE(IBINS,"^",6)
WRITE ?52,$SELECT(X="v":"SELF",X="s":"SPOUSE",1:"OTHER")
+4 WRITE ?60,$$DAT1^IBOUTL($PIECE(IBINS,"^",8)),?70,$$DAT1^IBOUTL($PIECE(IBINS,"^",4))
+5 QUIT
