- DGVPTIB6 ;alb/mjk - DGCRNS for export with PIMS v5.3; 4/21/93
- ;;5.3;Registration;**1015**;Aug 13, 1993;Build 21
- ;
- DGCRNS ;ALB/AAS - IS INSURANCE ACTIVE ; 22-JULY-91
- ;;Version 1.5 ; INTEGRATED BILLING ;**14**; 29-JUL-92
- ;
- Q ;ihs/cmi/maw 02/08/2012 patch 1014 no IB in IHS so entire routine not needed
- ;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
- DGVPTIB6 ;alb/mjk - DGCRNS for export with PIMS v5.3; 4/21/93
- +1 ;;5.3;Registration;**1015**;Aug 13, 1993;Build 21
- +2 ;
- DGCRNS ;ALB/AAS - IS INSURANCE ACTIVE ; 22-JULY-91
- +1 ;;Version 1.5 ; INTEGRATED BILLING ;**14**; 29-JUL-92
- +2 ;
- +3 ;ihs/cmi/maw 02/08/2012 patch 1014 no IB in IHS so entire routine not needed
- QUIT
- +4 ;Input - DFN = patient
- +5 ; - DGCRINDT = (optional) date to check ins active for or today if not defined
- +6 ; - DGCROUTP = (optional) 1 if want active insurance returned in DGCRDD(insurance company)=node in patient file
- +7 ; - = 2 if want all ins returned
- +8 ;
- +9 ;Output - DGCRINS = 1 if has active ins., 0 if no active ins.
- +10 ; - DGCRDD() = internal node in patient file of valid ins.
- +11 ; - DGCRDDI() = internal node in patient file of invalid ins.
- +12 ;
- % 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
