ACHSRPI1 ; IHS/ITSC/PMF - TPF RE-WRITE OF ACHSRPI ;
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**13**;JUN 11,2001
;ACHS*3.1*13 11/27/06 IHS/OIT/FCJ PRT POLICY # FR CORRECT FILES
;
;USED BY DENIAL LETTER ROUTINE ACHSDNL3 TO SHOW INSURANCES HELD BY
;PATIENT IF DENIAL REASON = ALTERNATE RESOURCES
;
TEST ;THIS LOOP FOR TESTING
S ACHSFAC=3 ;FOR TESTING
S U="^",INSTAB=15
K ACHSEFF
F S ACHSFAC=$O(^ACHSF(ACHSFAC)) Q:+ACHSFAC=0 D
.S ACHSDOC=0
.F S ACHSDOC=$O(^ACHSF(ACHSFAC,"D",ACHSDOC)) Q:+ACHSDOC=0 D
..S ACHSFDT=$P($G(^ACHSF(ACHSFAC,"D",ACHSDOC,3)),U)
..S ACHSTDT=$P($G(^ACHSF(ACHSFAC,"D",ACHSDOC,3)),U,2)
..S DFN=$P($G(^ACHSF(ACHSFAC,"D",ACHSDOC,0)),U,22)
..D PVTINS(DFN,ACHSFDT,ACHSTDT)
..D SUPINS(DFN,ACHSFDT,ACHSTDT)
..D BOX3H(DFN,.ACHSEFF)
Q
;
;
;DFN=PATIENT INTERNAL NUMBER
;ACHSFDT= AUTHORIZED FROM DATE
;ACHSEDT= ATUHORIZED TO DATE
;
;GET PRIVATE INSURANCE
;(PATIENT INTERNAL NUMBER,AUTH FROM DATE,AUTH TO DATE,FACILITY NUMBER,DOCUMENT NUMBER,IGNORE AUTHORZATION DATES)
;CALLED BY ACHDNL3
;
PVTINS(DFN,ACHSFDT,ACHSTDT,ACHSFAC,ACHSA,IGNORE) ;EP from ACHSDNL3
Q:DFN=""
S INSTAB=15
S ACHSDOC=$P($G(^ACHSDEN(ACHSFAC,"D",ACHSA,0)),U) ;DOC 0 NODE
S DTOFSERV=$P($G(^ACHSDEN(ACHSFAC,"D",ACHSA,0)),U,4) ;DATE OF MEDICAL SERVICE
S ACHSGLOB="AUPNPRVT"
S INSDA=0
F X=1:1 S INSDA=$O(^AUPNPRVT(DFN,11,INSDA)) Q:+INSDA=0 D
.S ACHSPINS=$G(^AUPNPRVT(DFN,11,INSDA,0))
.S ACHSPEDT=$P(ACHSPINS,U,6) ;POLICY EFFECTIVE DATE
.S ACHSPTDT=$P(ACHSPINS,U,7) ;POLICY TERMINATION DATE
.;
.;CHECK IF DATE OF MEDICAL SERVICE IS BEFORE POLICY EFFECTIVE DATE
.I DTOFSERV<ACHSPEDT Q
.;CHECK IF DATE OF MEDICAL SERVICE IS AFTER POLICY TERMINATION DATE
.I DTOFSERV>ACHSPTDT Q
.I X=1 W !!?INSTAB,"PRIVATE INSURANCE COVERAGE",!?INSTAB,"BASED ON DATE OF SERVICE: " S Y=DTOFSERV X ^DD("DD") W Y
.;ACHS*3.1*13 11/27/06 IHS/OIT/FCJ PRT POLICY # FR CORRECT FILES
.;S ACHSPNUM=$P(ACHSPINS,U,2) ;POLICY NUMBER
.I $P(ACHSPINS,U,8),$D(^AUPN3PPH($P(ACHSPINS,U,8),0)) S ACHSPNUM=$P(^AUPN3PPH($P(ACHSPINS,U,8),0),U,4) ;POLICY NUMBER
.S ACHSINSU=$P(ACHSPINS,U) ;INSURER PTR TO INSURER FILE 9999999.18
.I ACHSINSU="" S ACHSINAM=" --- "
.E S ACHSINAM=$P($G(^AUTNINS(ACHSINSU,0)),U) ;INSURER NAME
.D RESULT(ACHSPEDT,ACHSPTDT,ACHSFDT,ACHSTDT,ACHSINAM,ACHSPNUM,IGNORE,DTOFSERV)
D END
Q
;
;LOOK FOR SUPPLEMENTAL INSURANCE ; MEDICARE,MEDICAID,RAILROAD
;(PATIENT INTERNAL NUMBER,AUTH FROM DATE,AUTH TO DATE,FACILITY NUMBER,DOCUMENT NUMBER,IGNORE AUTHORIZATION DATES)
;CALLED BY ACHDNL3
;
SUPINS(DFN,ACHSFDT,ACHSTDT,ACHSFAC,ACHSA,IGNORE) ;EP from ACHSDNL3
Q:DFN=""
N ACHSEIN
S INSTAB=15
S ACHSDOC=$P($G(^ACHSDEN(ACHSFAC,"D",ACHSA,0)),U) ;DOC 0 NODE
S DTOFSERV=$P($G(^ACHSDEN(ACHSFAC,"D",ACHSA,0)),U,4) ;DATE OF MEDICAL SERVICE
F ACHSGLOB="^AUPNMCR","^AUPNMCD","^AUPNRRE" D
.S INSDA=0
.S ACHSEIN=DFN I ACHSGLOB["MCD" S ACHSEIN=$O(^AUPNMCD("B",DFN,""))
.I ACHSEIN="" Q
.;
.;9/13/01 pmf several lines changed below. DFN replaced ACHSEIN
.;
.F X=1:1 S INSDA=$O(@ACHSGLOB@(ACHSEIN,11,INSDA)) Q:+INSDA=0 D
..S ACHSPINS=$G(@ACHSGLOB@(ACHSEIN,11,INSDA,0)) ;
..S ACHSPIN0=$G(@ACHSGLOB@(ACHSEIN,0)) ;ZERO NODE
..S ACHSPEDT=$P(ACHSPINS,U) ;POLICY EFFECTIVE DATE
..S ACHSPTDT=$P(ACHSPINS,U,2) ;POLICY TERMINATION DATE
..;
..;CHECK IF DATE OF MEDICAL SERVICE IS BEFORE POLICY EFFECTIVE DATE
..I DTOFSERV<ACHSPEDT Q
..;CHECK IF DATE OF MEDICAL SERVICE IS AFTER POLICY TERMINATION DATE
..I DTOFSERV>ACHSPTDT Q
..;
..;I X=1 W !!?INSTAB,"SUPPLEMENTAL INSURANCE COVERAGE",!?INSTAB,"BASED ON DATE OF SERVICE: " S Y=DTOFSERV X ^DD("DD") W Y
..;
..S ACHSPNUM=""
..I ACHSGLOB="^AUPNRRE" S ACHSPNUM=$P(ACHSPIN0,U,4)
..E S ACHSPNUM=$P(ACHSPIN0,U,3) ;POLICY NUMBER
..S ACHSINSU=$P(ACHSPIN0,U,2) ;INSURER PTR TO INSURER FILE 9999999.18
..I ACHSINSU="" S ACHSINAM=" --- "
..E S ACHSINAM=$P($G(^AUTNINS(ACHSINSU,0)),U) ;INSURER NAME
..I ACHSGLOB="^AUPNMCR" S ACHSISUF=$P(ACHSPIN0,U,4) ;SUFFIX PTR TO
..E S ACHSISUF="" ;MEDICARE SUFFIX
..; ;9999999.32
..I ACHSISUF'="" S ACHSISUF=$P($G(^AUTTMCS(ACHSISUF,0)),U)
..I ACHSGLOB="^AUPNRRE" S ACHSIPRE=$P(ACHSPIN0,U,3) ;PREFIX PTR TO
..E S ACHSIPRE="" ;RAILROAD PREFIX
..I ACHSIPRE'="" S ACHSIPRE=$P($G(^AUPNRRE(ACHSIPRE,0)),U) ;9999999.33
..S ACHSPNUM=ACHSIPRE_" "_ACHSPNUM_" "_ACHSISUF
..D RESULT(ACHSPEDT,ACHSPTDT,ACHSFDT,ACHSTDT,ACHSINAM,ACHSPNUM,IGNORE,DTOFSERV)
D END
Q
;
;
;DECIDE WHETHER POLICY IS GOOD FOR AUTHORIZED DATE RANGE
;(POLICY EFFECT. DATE,POLICY TERM. DATE,AUTH FROM DATE,AUTH TO DATE)
;
POLGOOD(ACHSPEDT,ACHSPTDT,ACHSFDT,ACHSTDT,IGNORE) ;
S:ACHSPTDT="" ACHSPTDT=9999999
S:ACHSTDT="" ACHSTDT=9999999
;
I ACHSPEDT="" Q 10 ;MUST HAVE A POLICY EFFECTIVE
;DATE
;
I ACHSFDT="" Q 15 ;MUST HAVE AUTHORIZE FROM DATE
;
;
I ACHSPTDT<ACHSFDT Q 20 ;POLICY IS NO LONGER EFFECTIVE
;
;
I ACHSPTDT=9999999,ACHSTDT=9999999 D S Y=X X ^DD("DD") Q 200_U_Y
. ;IF POLICY TERMINATION DATE AND
. ;AUTHORIZATION TO DATE ARE OPEN
. ;TAKE LATEST OF THE TWO AS EFF
.S X=$S(ACHSPEDT>ACHSFDT:ACHSPEDT,1:ACHSFDT)
;
I ACHSPTDT=ACHSPEDT!(ACHSPTDT<ACHSPEDT) Q 30
;IF POLICY EFFECTIVE DATE
;EQUALS POLICY TERMINATION
;DATE OR POLICY TERMINATION
;DATE IS LESS THAN THE EFFEC.
;DATE THEN INVALID POLICY DATES
;
I ACHSPEDT<(ACHSFDT+1),(ACHSPTDT>(ACHSTDT+1)) Q 40
;IF POLICY EFFECTIVE DATE LESS
;THAN AUTH. FROM DATE AND
;POLICY TERMINATION DATE IS
;GREATER THAN AUTHORIZATION TO
;THEN FULL AUTH RANGE IS COVERE
;
I ACHSPEDT>(ACHSFDT-1),(ACHSPTDT<(ACHSTDT+1)) Q 45
;IF POLICY EFFECTIVE DATE IS
;GREATER THAN AUTH. FROM DATE
;AND THE POLICY TERM. DATE IS
;LESS THAN THE AUTH. TO DATE
;THEN PARTIAL AUTH
;RANGE IS COVERED
;
I ACHSPEDT>ACHSTDT Q 50 ;IF POLICY EFFECTIVE DATE
;IS GREATER THAN AUTH TO DATE
;THEN NO COVERAGE
;
I ACHSPTDT<ACHSFDT Q 20 ;IF POLICY TERM. DATE IS LESS
;THAN THE AUTH FROM DATE THEN
;NO COVERAGE
;
;
Q 100 ;UNDETERMINED
;
;
;PRINT RESULTS
;(POLICY EFFECT. DATE,POLICY TERM. DATE,AUTH FROM DATE,AUTH TO DATE,INSURER NAME,POLICY NUMBER)
;
RESULT(ACHSPEDT,ACHSPTDT,ACHSFDT,ACHSTDT,ACHSINAM,ACHSPNUM,RESULT,DTOFSERV) ;
S:$G(ACHSPEDT)="" ACHSPEDT=" --- "
S:$G(ACHSPTDT)="" ACHSPTDT=" --- "
S:$G(ACHSFDT)="" ACHSFDT=" --- "
S:$G(ACHSTDT)="" ACHSTDT=" --- "
S:$G(ACHSINAM)="" ACHSINAM=" --- "
S:$G(ACHSPNUM)="" ACHSPNUM=" --- "
S STAT=$$POLGOOD(ACHSPEDT,ACHSPTDT,ACHSFDT,ACHSTDT)
;
;W !!!,"GLOBAL: ",$G(ACHSGLOB)
;W !,"PATIENT: ",DFN,?35,"COVERAGE STATUS"
S INSTAB=15 ;INSURANCE INFO TAB
W !!?INSTAB,"INSURER: ",ACHSINAM
W !?INSTAB,"POLICY #: ",ACHSPNUM
;
I 'IGNORE D
. W !?INSTAB,"FOR AUTH. DATE RANGE: "
. ;
. ;here we translate the value of STAT into a human readable
. ;phrase. we have to keep line length down, so we do it
. ;in up to three steps.
. S ACHSYAYA=$S(+STAT=15:"MUST HAVE AUTH FROM DATE",+STAT=1:"YES",+STAT=100:"UNDETERMINED",+STAT=200:"YES AS OF "_$P(STAT,U,2),1:"")
. I ACHSYAYA="" S ACHSYAYA=$S(+STAT=10:"POLICY EFFECTIVE DATE MISSING",+STAT=20:"POLICY EXPIRED",+STAT=30:"INVALID POLICY DATES",+STAT=40:"FULL COVERAGE",1:"")
. I ACHSYAYA="" S ACHSYAYA=$S(+STAT=45:"PARTIAL COVERAGE",+STAT=50:"POLICY BEGINS AFTER AUTH ENDS",+STAT=0:"NO INACTIVE",1:"UNDETERMINED")
. W ACHSYAYA K ACHSYAYA
. Q
;
;
W !?INSTAB,"POLICY BEGIN: " S Y=ACHSPEDT X ^DD("DD") W Y
W !?INSTAB,"POLICY END: " S Y=ACHSPTDT X ^DD("DD") W Y
;
I 'IGNORE W !?INSTAB,"AUTH FROM: " S Y=ACHSFDT X ^DD("DD") W Y
I 'IGNORE W !?INSTAB,"AUTH TO: " S Y=ACHSTDT X ^DD("DD") W Y
;
I (U_1_U_200_U_40_U_45_U)'[(U_+STAT_U) S ACHSEFF(DFN,ACHSINAM,ACHSPEDT,ACHSPTDT,ACHSPNUM)="NO EFFECTIVE POLICIES FOUND"
;SET THE EFFECTIVE COVERAGE ARRAY
S ACHSEFF(DFN,ACHSINAM,ACHSPEDT,ACHSPTDT,ACHSPNUM)=STAT
Q
;
;DO OTHER HEALTH INSURANCE BOX 3 H
;(PATIENT INTERNAL NUMBER,ARRAY OF GOOD POLICIES)
BOX3H(DFN,ACHSEFF) ;
Q:DFN=""
Q:'$D(ACHSEFF(DFN))
W !!!,"*****************"
S ACHSNAM=""
F S ACHSNAM=$O(ACHSEFF(DFN,ACHSNAM)) Q:ACHSNAM="" D
.S ACHSPEDT=""
.F S ACHSPEDT=$O(ACHSEFF(DFN,ACHSNAM,ACHSPEDT)) Q:ACHSPEDT="" D
..S ACHSPTDT=""
..F S ACHSPTDT=$O(ACHSEFF(DFN,ACHSNAM,ACHSPEDT,ACHSPTDT)) Q:ACHSPTDT="" D
...S ACHSPNUM=""
...F S ACHSPNUM=$O(ACHSEFF(DFN,ACHSNAM,ACHSPEDT,ACHSPTDT,ACHSPNUM)) Q:ACHSPNUM="" D
....I ACHSEFF(DFN,ACHSNAM,ACHSPEDT,ACHSPTDT,ACHSPNUM)[("NO EFFECTIVE") W !,"***NO EFFECTIVE POLICIES FOUND!***" Q
....W !,DFN_" "_$P($G(^DPT(DFN,0)),U)
....W !,$E(ACHSNAM,1,8)_" "_ACHSPNUM
....W !?8,"EFF: "
....I ACHSPEDT=9999999 W ""
....E S Y=ACHSPEDT X ^DD("DD") W Y
....W " TERM: "
....I ACHSPTDT=9999999 W ""
....E S Y=ACHSPTDT X ^DD("DD") W Y
W !,"*******************",!!!
Q
;
;CLEAN UP VARAIABLES USED IN THIS ROUTINE
END ;
K ACHSGLOB,ACHSFAC,ACHSFDT,ACHSEFF,ACHSINAM,ACHSIPRE,ACHSINSU,ACHSISUF
K ACHSNAM,ACHSPEDT,ACHSPIN0,ACHSPINS,ACHSPNUM,ACHSPTDT,ACHSTDT,DTOFSERV,IGNORE,INSDA,INSTAB,RESULT,X,Y
Q
ACHSRPI1 ; IHS/ITSC/PMF - TPF RE-WRITE OF ACHSRPI ;
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**13**;JUN 11,2001
+2 ;ACHS*3.1*13 11/27/06 IHS/OIT/FCJ PRT POLICY # FR CORRECT FILES
+3 ;
+4 ;USED BY DENIAL LETTER ROUTINE ACHSDNL3 TO SHOW INSURANCES HELD BY
+5 ;PATIENT IF DENIAL REASON = ALTERNATE RESOURCES
+6 ;
TEST ;THIS LOOP FOR TESTING
+1 ;FOR TESTING
SET ACHSFAC=3
+2 SET U="^"
SET INSTAB=15
+3 KILL ACHSEFF
+4 FOR
SET ACHSFAC=$ORDER(^ACHSF(ACHSFAC))
IF +ACHSFAC=0
QUIT
Begin DoDot:1
+5 SET ACHSDOC=0
+6 FOR
SET ACHSDOC=$ORDER(^ACHSF(ACHSFAC,"D",ACHSDOC))
IF +ACHSDOC=0
QUIT
Begin DoDot:2
+7 SET ACHSFDT=$PIECE($GET(^ACHSF(ACHSFAC,"D",ACHSDOC,3)),U)
+8 SET ACHSTDT=$PIECE($GET(^ACHSF(ACHSFAC,"D",ACHSDOC,3)),U,2)
+9 SET DFN=$PIECE($GET(^ACHSF(ACHSFAC,"D",ACHSDOC,0)),U,22)
+10 DO PVTINS(DFN,ACHSFDT,ACHSTDT)
+11 DO SUPINS(DFN,ACHSFDT,ACHSTDT)
+12 DO BOX3H(DFN,.ACHSEFF)
End DoDot:2
End DoDot:1
+13 QUIT
+14 ;
+15 ;
+16 ;DFN=PATIENT INTERNAL NUMBER
+17 ;ACHSFDT= AUTHORIZED FROM DATE
+18 ;ACHSEDT= ATUHORIZED TO DATE
+19 ;
+20 ;GET PRIVATE INSURANCE
+21 ;(PATIENT INTERNAL NUMBER,AUTH FROM DATE,AUTH TO DATE,FACILITY NUMBER,DOCUMENT NUMBER,IGNORE AUTHORZATION DATES)
+22 ;CALLED BY ACHDNL3
+23 ;
PVTINS(DFN,ACHSFDT,ACHSTDT,ACHSFAC,ACHSA,IGNORE) ;EP from ACHSDNL3
+1 IF DFN=""
QUIT
+2 SET INSTAB=15
+3 ;DOC 0 NODE
SET ACHSDOC=$PIECE($GET(^ACHSDEN(ACHSFAC,"D",ACHSA,0)),U)
+4 ;DATE OF MEDICAL SERVICE
SET DTOFSERV=$PIECE($GET(^ACHSDEN(ACHSFAC,"D",ACHSA,0)),U,4)
+5 SET ACHSGLOB="AUPNPRVT"
+6 SET INSDA=0
+7 FOR X=1:1
SET INSDA=$ORDER(^AUPNPRVT(DFN,11,INSDA))
IF +INSDA=0
QUIT
Begin DoDot:1
+8 SET ACHSPINS=$GET(^AUPNPRVT(DFN,11,INSDA,0))
+9 ;POLICY EFFECTIVE DATE
SET ACHSPEDT=$PIECE(ACHSPINS,U,6)
+10 ;POLICY TERMINATION DATE
SET ACHSPTDT=$PIECE(ACHSPINS,U,7)
+11 ;
+12 ;CHECK IF DATE OF MEDICAL SERVICE IS BEFORE POLICY EFFECTIVE DATE
+13 IF DTOFSERV<ACHSPEDT
QUIT
+14 ;CHECK IF DATE OF MEDICAL SERVICE IS AFTER POLICY TERMINATION DATE
+15 IF DTOFSERV>ACHSPTDT
QUIT
+16 IF X=1
WRITE !!?INSTAB,"PRIVATE INSURANCE COVERAGE",!?INSTAB,"BASED ON DATE OF SERVICE: "
SET Y=DTOFSERV
XECUTE ^DD("DD")
WRITE Y
+17 ;ACHS*3.1*13 11/27/06 IHS/OIT/FCJ PRT POLICY # FR CORRECT FILES
+18 ;S ACHSPNUM=$P(ACHSPINS,U,2) ;POLICY NUMBER
+19 ;POLICY NUMBER
IF $PIECE(ACHSPINS,U,8)
IF $DATA(^AUPN3PPH($PIECE(ACHSPINS,U,8),0))
SET ACHSPNUM=$PIECE(^AUPN3PPH($PIECE(ACHSPINS,U,8),0),U,4)
+20 ;INSURER PTR TO INSURER FILE 9999999.18
SET ACHSINSU=$PIECE(ACHSPINS,U)
+21 IF ACHSINSU=""
SET ACHSINAM=" --- "
+22 ;INSURER NAME
IF '$TEST
SET ACHSINAM=$PIECE($GET(^AUTNINS(ACHSINSU,0)),U)
+23 DO RESULT(ACHSPEDT,ACHSPTDT,ACHSFDT,ACHSTDT,ACHSINAM,ACHSPNUM,IGNORE,DTOFSERV)
End DoDot:1
+24 DO END
+25 QUIT
+26 ;
+27 ;LOOK FOR SUPPLEMENTAL INSURANCE ; MEDICARE,MEDICAID,RAILROAD
+28 ;(PATIENT INTERNAL NUMBER,AUTH FROM DATE,AUTH TO DATE,FACILITY NUMBER,DOCUMENT NUMBER,IGNORE AUTHORIZATION DATES)
+29 ;CALLED BY ACHDNL3
+30 ;
SUPINS(DFN,ACHSFDT,ACHSTDT,ACHSFAC,ACHSA,IGNORE) ;EP from ACHSDNL3
+1 IF DFN=""
QUIT
+2 NEW ACHSEIN
+3 SET INSTAB=15
+4 ;DOC 0 NODE
SET ACHSDOC=$PIECE($GET(^ACHSDEN(ACHSFAC,"D",ACHSA,0)),U)
+5 ;DATE OF MEDICAL SERVICE
SET DTOFSERV=$PIECE($GET(^ACHSDEN(ACHSFAC,"D",ACHSA,0)),U,4)
+6 FOR ACHSGLOB="^AUPNMCR","^AUPNMCD","^AUPNRRE"
Begin DoDot:1
+7 SET INSDA=0
+8 SET ACHSEIN=DFN
IF ACHSGLOB["MCD"
SET ACHSEIN=$ORDER(^AUPNMCD("B",DFN,""))
+9 IF ACHSEIN=""
QUIT
+10 ;
+11 ;9/13/01 pmf several lines changed below. DFN replaced ACHSEIN
+12 ;
+13 FOR X=1:1
SET INSDA=$ORDER(@ACHSGLOB@(ACHSEIN,11,INSDA))
IF +INSDA=0
QUIT
Begin DoDot:2
+14 ;
SET ACHSPINS=$GET(@ACHSGLOB@(ACHSEIN,11,INSDA,0))
+15 ;ZERO NODE
SET ACHSPIN0=$GET(@ACHSGLOB@(ACHSEIN,0))
+16 ;POLICY EFFECTIVE DATE
SET ACHSPEDT=$PIECE(ACHSPINS,U)
+17 ;POLICY TERMINATION DATE
SET ACHSPTDT=$PIECE(ACHSPINS,U,2)
+18 ;
+19 ;CHECK IF DATE OF MEDICAL SERVICE IS BEFORE POLICY EFFECTIVE DATE
+20 IF DTOFSERV<ACHSPEDT
QUIT
+21 ;CHECK IF DATE OF MEDICAL SERVICE IS AFTER POLICY TERMINATION DATE
+22 IF DTOFSERV>ACHSPTDT
QUIT
+23 ;
+24 ;I X=1 W !!?INSTAB,"SUPPLEMENTAL INSURANCE COVERAGE",!?INSTAB,"BASED ON DATE OF SERVICE: " S Y=DTOFSERV X ^DD("DD") W Y
+25 ;
+26 SET ACHSPNUM=""
+27 IF ACHSGLOB="^AUPNRRE"
SET ACHSPNUM=$PIECE(ACHSPIN0,U,4)
+28 ;POLICY NUMBER
IF '$TEST
SET ACHSPNUM=$PIECE(ACHSPIN0,U,3)
+29 ;INSURER PTR TO INSURER FILE 9999999.18
SET ACHSINSU=$PIECE(ACHSPIN0,U,2)
+30 IF ACHSINSU=""
SET ACHSINAM=" --- "
+31 ;INSURER NAME
IF '$TEST
SET ACHSINAM=$PIECE($GET(^AUTNINS(ACHSINSU,0)),U)
+32 ;SUFFIX PTR TO
IF ACHSGLOB="^AUPNMCR"
SET ACHSISUF=$PIECE(ACHSPIN0,U,4)
+33 ;MEDICARE SUFFIX
IF '$TEST
SET ACHSISUF=""
+34 ; ;9999999.32
+35 IF ACHSISUF'=""
SET ACHSISUF=$PIECE($GET(^AUTTMCS(ACHSISUF,0)),U)
+36 ;PREFIX PTR TO
IF ACHSGLOB="^AUPNRRE"
SET ACHSIPRE=$PIECE(ACHSPIN0,U,3)
+37 ;RAILROAD PREFIX
IF '$TEST
SET ACHSIPRE=""
+38 ;9999999.33
IF ACHSIPRE'=""
SET ACHSIPRE=$PIECE($GET(^AUPNRRE(ACHSIPRE,0)),U)
+39 SET ACHSPNUM=ACHSIPRE_" "_ACHSPNUM_" "_ACHSISUF
+40 DO RESULT(ACHSPEDT,ACHSPTDT,ACHSFDT,ACHSTDT,ACHSINAM,ACHSPNUM,IGNORE,DTOFSERV)
End DoDot:2
End DoDot:1
+41 DO END
+42 QUIT
+43 ;
+44 ;
+45 ;DECIDE WHETHER POLICY IS GOOD FOR AUTHORIZED DATE RANGE
+46 ;(POLICY EFFECT. DATE,POLICY TERM. DATE,AUTH FROM DATE,AUTH TO DATE)
+47 ;
POLGOOD(ACHSPEDT,ACHSPTDT,ACHSFDT,ACHSTDT,IGNORE) ;
+1 IF ACHSPTDT=""
SET ACHSPTDT=9999999
+2 IF ACHSTDT=""
SET ACHSTDT=9999999
+3 ;
+4 ;MUST HAVE A POLICY EFFECTIVE
IF ACHSPEDT=""
QUIT 10
+5 ;DATE
+6 ;
+7 ;MUST HAVE AUTHORIZE FROM DATE
IF ACHSFDT=""
QUIT 15
+8 ;
+9 ;
+10 ;POLICY IS NO LONGER EFFECTIVE
IF ACHSPTDT<ACHSFDT
QUIT 20
+11 ;
+12 ;
+13 IF ACHSPTDT=9999999
IF ACHSTDT=9999999
Begin DoDot:1
+14 ;IF POLICY TERMINATION DATE AND
+15 ;AUTHORIZATION TO DATE ARE OPEN
+16 ;TAKE LATEST OF THE TWO AS EFF
+17 SET X=$SELECT(ACHSPEDT>ACHSFDT:ACHSPEDT,1:ACHSFDT)
End DoDot:1
SET Y=X
XECUTE ^DD("DD")
QUIT 200_U_Y
+18 ;
+19 IF ACHSPTDT=ACHSPEDT!(ACHSPTDT<ACHSPEDT)
QUIT 30
+20 ;IF POLICY EFFECTIVE DATE
+21 ;EQUALS POLICY TERMINATION
+22 ;DATE OR POLICY TERMINATION
+23 ;DATE IS LESS THAN THE EFFEC.
+24 ;DATE THEN INVALID POLICY DATES
+25 ;
+26 IF ACHSPEDT<(ACHSFDT+1)
IF (ACHSPTDT>(ACHSTDT+1))
QUIT 40
+27 ;IF POLICY EFFECTIVE DATE LESS
+28 ;THAN AUTH. FROM DATE AND
+29 ;POLICY TERMINATION DATE IS
+30 ;GREATER THAN AUTHORIZATION TO
+31 ;THEN FULL AUTH RANGE IS COVERE
+32 ;
+33 IF ACHSPEDT>(ACHSFDT-1)
IF (ACHSPTDT<(ACHSTDT+1))
QUIT 45
+34 ;IF POLICY EFFECTIVE DATE IS
+35 ;GREATER THAN AUTH. FROM DATE
+36 ;AND THE POLICY TERM. DATE IS
+37 ;LESS THAN THE AUTH. TO DATE
+38 ;THEN PARTIAL AUTH
+39 ;RANGE IS COVERED
+40 ;
+41 ;IF POLICY EFFECTIVE DATE
IF ACHSPEDT>ACHSTDT
QUIT 50
+42 ;IS GREATER THAN AUTH TO DATE
+43 ;THEN NO COVERAGE
+44 ;
+45 ;IF POLICY TERM. DATE IS LESS
IF ACHSPTDT<ACHSFDT
QUIT 20
+46 ;THAN THE AUTH FROM DATE THEN
+47 ;NO COVERAGE
+48 ;
+49 ;
+50 ;UNDETERMINED
QUIT 100
+51 ;
+52 ;
+53 ;PRINT RESULTS
+54 ;(POLICY EFFECT. DATE,POLICY TERM. DATE,AUTH FROM DATE,AUTH TO DATE,INSURER NAME,POLICY NUMBER)
+55 ;
RESULT(ACHSPEDT,ACHSPTDT,ACHSFDT,ACHSTDT,ACHSINAM,ACHSPNUM,RESULT,DTOFSERV) ;
+1 IF $GET(ACHSPEDT)=""
SET ACHSPEDT=" --- "
+2 IF $GET(ACHSPTDT)=""
SET ACHSPTDT=" --- "
+3 IF $GET(ACHSFDT)=""
SET ACHSFDT=" --- "
+4 IF $GET(ACHSTDT)=""
SET ACHSTDT=" --- "
+5 IF $GET(ACHSINAM)=""
SET ACHSINAM=" --- "
+6 IF $GET(ACHSPNUM)=""
SET ACHSPNUM=" --- "
+7 SET STAT=$$POLGOOD(ACHSPEDT,ACHSPTDT,ACHSFDT,ACHSTDT)
+8 ;
+9 ;W !!!,"GLOBAL: ",$G(ACHSGLOB)
+10 ;W !,"PATIENT: ",DFN,?35,"COVERAGE STATUS"
+11 ;INSURANCE INFO TAB
SET INSTAB=15
+12 WRITE !!?INSTAB,"INSURER: ",ACHSINAM
+13 WRITE !?INSTAB,"POLICY #: ",ACHSPNUM
+14 ;
+15 IF 'IGNORE
Begin DoDot:1
+16 WRITE !?INSTAB,"FOR AUTH. DATE RANGE: "
+17 ;
+18 ;here we translate the value of STAT into a human readable
+19 ;phrase. we have to keep line length down, so we do it
+20 ;in up to three steps.
+21 SET ACHSYAYA=$SELECT(+STAT=15:"MUST HAVE AUTH FROM DATE",+STAT=1:"YES",+STAT=100:"UNDETERMINED",+STAT=200:"YES AS OF "_$PIECE(STAT,U,2),1:"")
+22 IF ACHSYAYA=""
SET ACHSYAYA=$SELECT(+STAT=10:"POLICY EFFECTIVE DATE MISSING",+STAT=20:"POLICY EXPIRED",+STAT=30:"INVALID POLICY DATES",+STAT=40:"FULL COVERAGE",1:"")
+23 IF ACHSYAYA=""
SET ACHSYAYA=$SELECT(+STAT=45:"PARTIAL COVERAGE",+STAT=50:"POLICY BEGINS AFTER AUTH ENDS",+STAT=0:"NO INACTIVE",1:"UNDETERMINED")
+24 WRITE ACHSYAYA
KILL ACHSYAYA
+25 QUIT
End DoDot:1
+26 ;
+27 ;
+28 WRITE !?INSTAB,"POLICY BEGIN: "
SET Y=ACHSPEDT
XECUTE ^DD("DD")
WRITE Y
+29 WRITE !?INSTAB,"POLICY END: "
SET Y=ACHSPTDT
XECUTE ^DD("DD")
WRITE Y
+30 ;
+31 IF 'IGNORE
WRITE !?INSTAB,"AUTH FROM: "
SET Y=ACHSFDT
XECUTE ^DD("DD")
WRITE Y
+32 IF 'IGNORE
WRITE !?INSTAB,"AUTH TO: "
SET Y=ACHSTDT
XECUTE ^DD("DD")
WRITE Y
+33 ;
+34 IF (U_1_U_200_U_40_U_45_U)'[(U_+STAT_U)
SET ACHSEFF(DFN,ACHSINAM,ACHSPEDT,ACHSPTDT,ACHSPNUM)="NO EFFECTIVE POLICIES FOUND"
+35 ;SET THE EFFECTIVE COVERAGE ARRAY
+36 SET ACHSEFF(DFN,ACHSINAM,ACHSPEDT,ACHSPTDT,ACHSPNUM)=STAT
+37 QUIT
+38 ;
+39 ;DO OTHER HEALTH INSURANCE BOX 3 H
+40 ;(PATIENT INTERNAL NUMBER,ARRAY OF GOOD POLICIES)
BOX3H(DFN,ACHSEFF) ;
+1 IF DFN=""
QUIT
+2 IF '$DATA(ACHSEFF(DFN))
QUIT
+3 WRITE !!!,"*****************"
+4 SET ACHSNAM=""
+5 FOR
SET ACHSNAM=$ORDER(ACHSEFF(DFN,ACHSNAM))
IF ACHSNAM=""
QUIT
Begin DoDot:1
+6 SET ACHSPEDT=""
+7 FOR
SET ACHSPEDT=$ORDER(ACHSEFF(DFN,ACHSNAM,ACHSPEDT))
IF ACHSPEDT=""
QUIT
Begin DoDot:2
+8 SET ACHSPTDT=""
+9 FOR
SET ACHSPTDT=$ORDER(ACHSEFF(DFN,ACHSNAM,ACHSPEDT,ACHSPTDT))
IF ACHSPTDT=""
QUIT
Begin DoDot:3
+10 SET ACHSPNUM=""
+11 FOR
SET ACHSPNUM=$ORDER(ACHSEFF(DFN,ACHSNAM,ACHSPEDT,ACHSPTDT,ACHSPNUM))
IF ACHSPNUM=""
QUIT
Begin DoDot:4
+12 IF ACHSEFF(DFN,ACHSNAM,ACHSPEDT,ACHSPTDT,ACHSPNUM)[("NO EFFECTIVE")
WRITE !,"***NO EFFECTIVE POLICIES FOUND!***"
QUIT
+13 WRITE !,DFN_" "_$PIECE($GET(^DPT(DFN,0)),U)
+14 WRITE !,$EXTRACT(ACHSNAM,1,8)_" "_ACHSPNUM
+15 WRITE !?8,"EFF: "
+16 IF ACHSPEDT=9999999
WRITE ""
+17 IF '$TEST
SET Y=ACHSPEDT
XECUTE ^DD("DD")
WRITE Y
+18 WRITE " TERM: "
+19 IF ACHSPTDT=9999999
WRITE ""
+20 IF '$TEST
SET Y=ACHSPTDT
XECUTE ^DD("DD")
WRITE Y
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+21 WRITE !,"*******************",!!!
+22 QUIT
+23 ;
+24 ;CLEAN UP VARAIABLES USED IN THIS ROUTINE
END ;
+1 KILL ACHSGLOB,ACHSFAC,ACHSFDT,ACHSEFF,ACHSINAM,ACHSIPRE,ACHSINSU,ACHSISUF
+2 KILL ACHSNAM,ACHSPEDT,ACHSPIN0,ACHSPINS,ACHSPNUM,ACHSPTDT,ACHSTDT,DTOFSERV,IGNORE,INSDA,INSTAB,RESULT,X,Y
+3 QUIT
