APSQPINS ;IHS/ITSC/ENM - FIND ALL PRIVATE INSURANCE [ 08/29/2003 3:26 PM ];30-Aug-2006 10:40;SM
;;7.0;IHS PHARMACY MODIFICATIONS;**1005**;11/11/2002
; Modified - IHS/CIA/PLS - 03/11/04
; IHS/MSC/PLS - 08/30/06 - updated MCR API
Q
PIN(P,D,F,CNT) ;EP - return private insurer name for patient P on date D in form F
I '$G(P) Q 0
I '$G(D) Q 0
N I,Y,Z
S Z=""
S F=$G(F)
S Y="",U="^"
I '$D(^DPT(P,0)) G PINX
I $P(^DPT(P,0),U,19) G PINX
I '$D(^AUPNPAT(P,0)) G PINX
I '$D(^AUPNPRVT(P,11)) G PINX
I $D(^DPT(P,.35)),$P(^(.35),U)]"",$P(^(.35),U)<D G PINX
S I=0
S CNT("A")=0
F S I=$O(^AUPNPRVT(P,11,I)) Q:I'=+I D
. Q:$P(^AUPNPRVT(P,11,I,0),U)=""
. S Y=$P(^AUPNPRVT(P,11,I,0),U)
. Q:$P(^AUTNINS(Y,0),U)["AHCCCS"
. Q:$P(^AUPNPRVT(P,11,I,0),U,6)>D
. N GP,DE ;GRACE PERIOD FOR THIS INSURER
. S GP=$$GP(Y)
. S DE=$$FMADD^XLFDT(D,-GP) ;TAKE INTO ACCOUNT GRACE PERIOD
. Q:($P(^AUPNPRVT(P,11,I,0),U,7)]"")&($P(^(0),U,7)<DE)
. S Y=$S(F="E":$P(^AUTNINS(Y,0),U),1:Y)
. S Z=$G(Z)_", "_Y_"*"_GP_"*"
. S CNT("A")=CNT("A")+1
. Q
S Z=$E(Z,3,999) ;GET RID OF FIRST LETTER ','
PINX ;
Q Z
;
MCR(P,D) ;EP - patient P medicare eligible on date D. IHS/OKCAO/POC 11/23/2001
; I = IEN in ^AUPNMCR multiple.
;Returns the Medicare Insurer IEN^Plan IEN
Q:'$G(P) 0
Q:'$G(D) 0
N I,Y
S Y=0
I '$D(^DPT(P,0)) G MCRX
I $P(^DPT(P,0),U,19) G MCRX
I '$D(^AUPNPAT(P,0)) G MCRX
I '$D(^AUPNMCR(P,11)) G MCRX
I $D(^DPT(P,.35)),$P(^(.35),U)]"",$P(^(.35),U)<D G MCRX
S I=0
F S I=$O(^AUPNMCR(P,11,I)) Q:I'=+I D
.Q:$P(^AUPNMCR(P,11,I,0),U)>D
.N GP,DE ;GRACE PERIOD,DATE ENDING
.S GP=$$GP($P(^AUPNMCR(P,0),U,2))
.S DE=$$FMADD^XLFDT(D,-GP)
.I $P(^AUPNMCR(P,11,I,0),U,2)]"",$P(^(0),U,2)<DE Q
.S Y=$P(^AUPNMCR(P,0),U,2)_U_$P(^AUPNMCR(P,11,I,0),U,4) ;IHS/MSC/PLS - 08/30/06 - Added Plan IEN
MCRX Q Y
;
MCD(P,D) ;EP - patient P medicaid eligible on date D. IHS/OKCAO/POC 11/23/2001
;RETURNS THE PATIENT IEN IN THE INSURER FILE IHS/OKCAO/POC
; I = IEN.
; J = Node 11 IEN in ^AUPNMCD.
I '$G(P) Q 0
I '$G(D) Q 0
N I,J,Y,INSURER,STATE,NODE0
S Y=0,U="^"
I '$D(^DPT(P,0)) G MCDX
I $P(^DPT(P,0),U,19) G MCDX
I '$D(^AUPNPAT(P,0)) G MCDX
I $D(^DPT(P,.35)),$P(^(.35),U)]"",$P(^(.35),U)<D G MCDX
S I=0 F S I=$O(^AUPNMCD("B",P,I)) Q:I'=+I D
.Q:'$D(^AUPNMCD(I,11))
.S J=0 F S J=$O(^AUPNMCD(I,11,J)) Q:J'=+J D
..Q:J>D
..N GP,DE,NODE0,INSURER,INSURERR ;GRACE PERIOD ENDING DATE,NODE 0 ,INSURER FILE,POINTER TO STATE MEDICAID INSURER
..S NODE0=$G(^AUPNMCD(I,0))
..S INSURER=$P(NODE0,U,2),STATE=$P(NODE0,U,4)
..I 'INSURER!('STATE) Q
..S INSURERR=$P($G(^AUTNINS(INSURER,13,STATE,0)),U,2)
..S GP=$$GP(INSURERR)
..S DE=$$FMADD^XLFDT(DT,-GP)
.. ;I $P(^AUPNMCD(I,11,J,0),U,2)]"",$P(^(0),U,2)<D Q
..I $P(^AUPNMCD(I,11,J,0),U,2)]"",$P(^(0),U,2)<DE Q
..S Y=INSURERR
..Q
.Q
;
MCDX ;
Q Y
;
;
GP(INS) ;EP - GRACE PERIOD FOR AN INSURER-LOOK AT DEFAULT AND INDIVIDUAL INSURER IHS/OKCAO/POC 11/23/2001
N DEFINS,SPECINS,Y
S Y=0
I '+INS Q Y
S DEFINS=$$GET1^DIQ(9002313.99,"1,",951)
S Y=+DEFINS
S SPECINS=$$GET1^DIQ(9002313.4,INS_",",100.08)
S:+SPECINS Y=+SPECINS
Q Y
APSQPINS ;IHS/ITSC/ENM - FIND ALL PRIVATE INSURANCE [ 08/29/2003 3:26 PM ];30-Aug-2006 10:40;SM
+1 ;;7.0;IHS PHARMACY MODIFICATIONS;**1005**;11/11/2002
+2 ; Modified - IHS/CIA/PLS - 03/11/04
+3 ; IHS/MSC/PLS - 08/30/06 - updated MCR API
+4 QUIT
PIN(P,D,F,CNT) ;EP - return private insurer name for patient P on date D in form F
+1 IF '$GET(P)
QUIT 0
+2 IF '$GET(D)
QUIT 0
+3 NEW I,Y,Z
+4 SET Z=""
+5 SET F=$GET(F)
+6 SET Y=""
SET U="^"
+7 IF '$DATA(^DPT(P,0))
GOTO PINX
+8 IF $PIECE(^DPT(P,0),U,19)
GOTO PINX
+9 IF '$DATA(^AUPNPAT(P,0))
GOTO PINX
+10 IF '$DATA(^AUPNPRVT(P,11))
GOTO PINX
+11 IF $DATA(^DPT(P,.35))
IF $PIECE(^(.35),U)]""
IF $PIECE(^(.35),U)<D
GOTO PINX
+12 SET I=0
+13 SET CNT("A")=0
+14 FOR
SET I=$ORDER(^AUPNPRVT(P,11,I))
IF I'=+I
QUIT
Begin DoDot:1
+15 IF $PIECE(^AUPNPRVT(P,11,I,0),U)=""
QUIT
+16 SET Y=$PIECE(^AUPNPRVT(P,11,I,0),U)
+17 IF $PIECE(^AUTNINS(Y,0),U)["AHCCCS"
QUIT
+18 IF $PIECE(^AUPNPRVT(P,11,I,0),U,6)>D
QUIT
+19 ;GRACE PERIOD FOR THIS INSURER
NEW GP,DE
+20 SET GP=$$GP(Y)
+21 ;TAKE INTO ACCOUNT GRACE PERIOD
SET DE=$$FMADD^XLFDT(D,-GP)
+22 IF ($PIECE(^AUPNPRVT(P,11,I,0),U,7)]"")&($PIECE(^(0),U,7)<DE)
QUIT
+23 SET Y=$SELECT(F="E":$PIECE(^AUTNINS(Y,0),U),1:Y)
+24 SET Z=$GET(Z)_", "_Y_"*"_GP_"*"
+25 SET CNT("A")=CNT("A")+1
+26 QUIT
End DoDot:1
+27 ;GET RID OF FIRST LETTER ','
SET Z=$EXTRACT(Z,3,999)
PINX ;
+1 QUIT Z
+2 ;
MCR(P,D) ;EP - patient P medicare eligible on date D. IHS/OKCAO/POC 11/23/2001
+1 ; I = IEN in ^AUPNMCR multiple.
+2 ;Returns the Medicare Insurer IEN^Plan IEN
+3 IF '$GET(P)
QUIT 0
+4 IF '$GET(D)
QUIT 0
+5 NEW I,Y
+6 SET Y=0
+7 IF '$DATA(^DPT(P,0))
GOTO MCRX
+8 IF $PIECE(^DPT(P,0),U,19)
GOTO MCRX
+9 IF '$DATA(^AUPNPAT(P,0))
GOTO MCRX
+10 IF '$DATA(^AUPNMCR(P,11))
GOTO MCRX
+11 IF $DATA(^DPT(P,.35))
IF $PIECE(^(.35),U)]""
IF $PIECE(^(.35),U)<D
GOTO MCRX
+12 SET I=0
+13 FOR
SET I=$ORDER(^AUPNMCR(P,11,I))
IF I'=+I
QUIT
Begin DoDot:1
+14 IF $PIECE(^AUPNMCR(P,11,I,0),U)>D
QUIT
+15 ;GRACE PERIOD,DATE ENDING
NEW GP,DE
+16 SET GP=$$GP($PIECE(^AUPNMCR(P,0),U,2))
+17 SET DE=$$FMADD^XLFDT(D,-GP)
+18 IF $PIECE(^AUPNMCR(P,11,I,0),U,2)]""
IF $PIECE(^(0),U,2)<DE
QUIT
+19 ;IHS/MSC/PLS - 08/30/06 - Added Plan IEN
SET Y=$PIECE(^AUPNMCR(P,0),U,2)_U_$PIECE(^AUPNMCR(P,11,I,0),U,4)
End DoDot:1
MCRX QUIT Y
+1 ;
MCD(P,D) ;EP - patient P medicaid eligible on date D. IHS/OKCAO/POC 11/23/2001
+1 ;RETURNS THE PATIENT IEN IN THE INSURER FILE IHS/OKCAO/POC
+2 ; I = IEN.
+3 ; J = Node 11 IEN in ^AUPNMCD.
+4 IF '$GET(P)
QUIT 0
+5 IF '$GET(D)
QUIT 0
+6 NEW I,J,Y,INSURER,STATE,NODE0
+7 SET Y=0
SET U="^"
+8 IF '$DATA(^DPT(P,0))
GOTO MCDX
+9 IF $PIECE(^DPT(P,0),U,19)
GOTO MCDX
+10 IF '$DATA(^AUPNPAT(P,0))
GOTO MCDX
+11 IF $DATA(^DPT(P,.35))
IF $PIECE(^(.35),U)]""
IF $PIECE(^(.35),U)<D
GOTO MCDX
+12 SET I=0
FOR
SET I=$ORDER(^AUPNMCD("B",P,I))
IF I'=+I
QUIT
Begin DoDot:1
+13 IF '$DATA(^AUPNMCD(I,11))
QUIT
+14 SET J=0
FOR
SET J=$ORDER(^AUPNMCD(I,11,J))
IF J'=+J
QUIT
Begin DoDot:2
+15 IF J>D
QUIT
+16 ;GRACE PERIOD ENDING DATE,NODE 0 ,INSURER FILE,POINTER TO STATE MEDICAID INSURER
NEW GP,DE,NODE0,INSURER,INSURERR
+17 SET NODE0=$GET(^AUPNMCD(I,0))
+18 SET INSURER=$PIECE(NODE0,U,2)
SET STATE=$PIECE(NODE0,U,4)
+19 IF 'INSURER!('STATE)
QUIT
+20 SET INSURERR=$PIECE($GET(^AUTNINS(INSURER,13,STATE,0)),U,2)
+21 SET GP=$$GP(INSURERR)
+22 SET DE=$$FMADD^XLFDT(DT,-GP)
+23 ;I $P(^AUPNMCD(I,11,J,0),U,2)]"",$P(^(0),U,2)<D Q
+24 IF $PIECE(^AUPNMCD(I,11,J,0),U,2)]""
IF $PIECE(^(0),U,2)<DE
QUIT
+25 SET Y=INSURERR
+26 QUIT
End DoDot:2
+27 QUIT
End DoDot:1
+28 ;
MCDX ;
+1 QUIT Y
+2 ;
+3 ;
GP(INS) ;EP - GRACE PERIOD FOR AN INSURER-LOOK AT DEFAULT AND INDIVIDUAL INSURER IHS/OKCAO/POC 11/23/2001
+1 NEW DEFINS,SPECINS,Y
+2 SET Y=0
+3 IF '+INS
QUIT Y
+4 SET DEFINS=$$GET1^DIQ(9002313.99,"1,",951)
+5 SET Y=+DEFINS
+6 SET SPECINS=$$GET1^DIQ(9002313.4,INS_",",100.08)
+7 IF +SPECINS
SET Y=+SPECINS
+8 QUIT Y
