ABSPOSR7.m

ABSPOSR7 ;IHS/OIT/SCR - POS Insurance Report ;

 ;;1.0;PHARMACY POINT OF SALE;**38,50**;JUN 01, 2001  ;Build 38

 ;;

 ;;BASED ON FILE ABMRMCRD - 2.6;IHS 3P BILLING SYSTEM;;NOV 12, 2009

 Q

EN  ;ENTRY POINT from ABSP RPT INSURER REPORT

 N ABSPLINE,ABSPINS,ABSPLIST,ABSPTYPE,ABSPTYPI,ABSPELDT,ABSPDEAD,ABSPDTL

 N ABSPCNT,ABSPTOT,ABSPSU,ABSPNAME

 S $P(ABSPLINE,"-",79)="-"

 D MESSAGE  ;message about report

 S ABSPDTL=0

 S ABSPTYPE=$$INSTYPE()

 Q:ABSPTYPE=-1

 S ABSPTYPI=$P(ABSPTYPE,":",1)

 S ABSPTYPE=$P(ABSPTYPE,":",2)

 S ABSPINS=$$INS(ABSPTYPI)

 Q:ABSPINS=-1

 W !,"Reporting For Insurance Type: "_ABSPTYPE

 D GETINS(ABSPINS,ABSPTYPI,.ABSPLIST,.ABSPNAME) ;get list of insurers we're looking for

 D DISP(.ABSPNAME)  ;display list

 S ABSPELDT=$$ELIGDT()  ;get list for what date?

 Q:ABSPELDT=-1

 S ABSPDEAD=$$INACT()  ;include inactive/deceased pts?

 Q:ABSPDEAD=-1

 I ABSPINS=""

 S:ABSPINS'="ALL" ABSPDTL=$$DETAILQ()  ;detail?

 Q:ABSPDTL=-1

 D DEVSEL

 W !,"Gathering data...",!

 D COUNTIT(.ABSPLIST,ABSPTYPE,ABSPELDT,ABSPDEAD,.ABSPCNT,.ABSPTOT,.ABSPSU) ;go count data

 D OUTPUT(ABSPTYPE,ABSPELDT,ABSPDTL,.ABSPNAME,.ABSPCNT,.ABSPTOT,.ABSPSU)

 Q

 ;

MESSAGE ;

 W !?2,"This option will print information about the number of registered patients"

 W !?2,"who are currently enrolled in an insurance type that you will select."

 W !?2,"You will be asked if you wish to include only active patients."

 W !?2,"You will be asked to select a particular POS insurance company of the type selected"

 W !?2,"PATIENT DETAIL can be selected unless ALL insurance companies are specified"

 W !!?2,"You will be asked to enter an ""As of"" date to be used in determining"

 W !?2,"those patients who are ""actively"" enrolled in a plan of the selected type."

 Q

 ;

INSTYPE()  ;SELECT THE TYPE OF INSURER TO REPORT ON

 N DIX,X,Y

 S DIR(0)="SX^D:MEDICAID FI;P:PRIVATE;MD:MEDICARE PART D"

 S DIR("B")="MD"

 S DIR("A")="SELECT INSURER TYPE"

 D ^DIR

 Q:$D(DUOUT)!$D(DIROUT)!$D(DIRUT)!$D(DTOUT) -1

 Q X_":"_$G(Y(0))

 ;

INS(ABSPTYPE) ; SELECT THE INSURER OR CHOOSE ALL INSURERS

 N DIC,X,Y,ABSPINS

 S DIC(0)="AEMNQZ"

 S DIC("A")="Please choose an insurer or leave blank for ALL: "

 S DIC="^ABSPEI("

 S DIC("S")="I $P(^AUTNINS($P($G(^ABSPEI(Y,0)),U,1),2),U,1)="""_ABSPTYPE_""""

 D ^DIC K DIC

 Q:$D(DUOUT)!$D(DIROUT)!$D(DIRUT)!$D(DTOUT) -1

 I Y=-1 S ABSPINS="ALL"

 I Y'=-1 S ABSPINS=$P(Y,"^",1) ;,ABSPINSN=$P(Y,"^",2)

 Q ABSPINS

 ;

GETINS(ABSPINS,ABSPTYPE,ABSPLIST,ABSPNAME) ;RETURN info on specified insurer or all of identified type

 ;

 N ABSPNAM,ABSPNS

 S ABSPNS=0

 I ABSPINS="ALL" D

 .F  S ABSPNS=$O(^ABSPEI(ABSPNS)) Q:+ABSPNS=0  D

 ..I $P(^AUTNINS($P($G(^ABSPEI(ABSPNS,0)),U,1),2),U,1)=ABSPTYPE D

 ...S ABSPNAM=$P($G(^AUTNINS(ABSPNS,0)),U)

 ...S ABSPLIST(ABSPNS)=ABSPNAM

 ...S ABSPNAME(ABSPNAM,ABSPNS)=""

 I ABSPINS'="ALL" D

 .S ABSPNAM=$P($G(^AUTNINS(ABSPINS,0)),U)

 .S ABSPLIST(ABSPINS)=ABSPNAM

 .S ABSPNAME(ABSPNAM,ABSPINS)=""

 Q

 ;

DISP(ABSPNAME) ;display list of insurers

 N ABSPNAM

 W !,"     The following POS Insurer(s) will be included on this report:"

 S ABSPNAM=""

 I $O(ABSPNAME(""))="" W !,"No POS Insurers Found" Q

 F  S ABSPNAM=$O(ABSPNAME(ABSPNAM)) Q:ABSPNAM=""  W !,"  "_ABSPNAM

 Q

 ;

ELIGDT() ;get list for what date-default to today

 N ABSPELDT

 W !

 K DIR,DIC,DIE,X,Y,DR

 S DIR(0)="D"

 S DIR("A")="Display eligibility as of what date?"

 S DIR("B")="Today"

 D ^DIR

 K DIR

 Q:$D(DUOUT)!$D(DIROUT)!$D(DIRUT)!$D(DTOUT) -1

 S ABSPELDT=+Y

 W "  ("_Y(0)_")"  ;display date selected

 Q ABSPELDT

 ;

INACT() ;include inactive/deceased pts?

 W !

 N DIR,DIC,DIE,X,Y,DR,ABSPALL

 S DIR(0)="Y"

 S DIR("A")="Do you wish to EXCLUDE inactive and deceased patients"

 S DIR("B")="YES"

 D ^DIR

 Q:$D(DUOUT)!$D(DIROUT)!$D(DIRUT)!$D(DTOUT) -1

 I Y=1 S ABSPALL=0  ;exclude

 E  S ABSPALL=1  ;include all patients

 Q ABSPALL

DETAILQ() ;

 W !

 N DIR,DIC,DIE,X,Y,DR,ABSPDTL

 S DIR(0)="Y"

 S DIR("A")="Do you wish to view detail (patients)"

 S DIR("B")="NO"

 D ^DIR

 Q:$D(DUOUT)!$D(DIROUT)!$D(DIRUT)!$D(DTOUT) -1

 I Y=1 S ABSPDTL=1  ;detail

 E  S ABSPDTL=0  ;summary

 Q ABSPDTL

 ;

COUNTIT(ABSPLIST,ABSPTYPE,ABSPELDT,ABSPDEAD,ABSPCNT,ABSPTOT,ABSPSU) ;do counts for selected insurers

 I (ABSPTYPE="MEDICAID FI") D MEDICAID(.ABSPLIST,ABSPELDT,ABSPDEAD,.ABSPCNT,.ABSPTOT,.ABSPSU)

 I (ABSPTYPE="PRIVATE") D PRIVATE(.ABSPLIST,ABSPELDT,ABSPDEAD,.ABSPCNT,.ABSPTOT,.ABSPSU)

 I (ABSPTYPE="MEDICARE PART D") D MEDICARE(.ABSPLIST,ABSPELDT,ABSPDEAD,.ABSPCNT,.ABSPTOT,.ABSPSU)

 Q

 ;

MEDICARE(ABSPLIST,ABSPELDT,ABSPDEAD,ABSPCNT,ABSPTOT,ABSPSU) ;

 N ABSPEN,ABSPEIEN,ABSPCOV,ABSPQUIT,ABSPSDT,ABSPEDT,ABSPHRN,ABSPNAM,ABSPHRNS,ABSPPIEN,ABSPHRNN

 N ABSPPN,ABSPSUC,ABSPSUS,ABSPDPT

 S ABSPEN=0,ABSPQUIT=0

 F  S ABSPEN=$O(^AUPNMCR(ABSPEN)) Q:+ABSPEN=0  D

 .S ABSPDPT=$P(^AUPNMCR(ABSPEN,0),U,1)

 .Q:$G(^DPT(ABSPDPT,0))=""  ;Still have to look out for that...

 .I $D(^DPT(ABSPDPT,.35)),$P(^(.35),U,1)]"",$P(^(.35),U,1)<ABSPELDT Q

 .S ABSPEIEN=0

 .F  S ABSPEIEN=$O(^AUPNMCR(ABSPEN,11,ABSPEIEN)) Q:+ABSPEIEN=0  D

 ..S ABSPCOV=$P($G(^AUPNMCR(ABSPEN,11,ABSPEIEN,0)),U,3)  ;coverage type

 ..Q:ABSPCOV'="D"

 ..S ABSPPIEN=$P($G(^AUPNMCR(ABSPEN,11,ABSPEIEN,0)),U,4) ; plan name (pointer to ins file)

 ..I ($G(ABSPPIEN)="") S ABSPQUIT=1 Q

 ..I ($G(ABSPLIST(ABSPPIEN))="") S ABSPQUIT=1 Q  ;no entry for insurer on requested list

 ..I ABSPDEAD=0,($P($G(^DPT(ABSPEN,.35)),U)'="") S ABSPQUIT=1 Q  ;check exclude flag and DOD

 ..S ABSPSDT=$P($G(^AUPNMCR(ABSPEN,11,ABSPEIEN,0)),U) ;ELIG START DATE

 ..S ABSPEDT=$P($G(^AUPNMCR(ABSPEN,11,ABSPEIEN,0)),U,2) ;ELIG END DATE

 ..I (ABSPSDT<=ABSPELDT)&((ABSPEDT>ABSPELDT)!(ABSPEDT="")) D

 ...S ABSPHRN=0

 ...F  S ABSPHRN=$O(^AUPNPAT(ABSPEN,41,ABSPHRN)) Q:+ABSPHRN=0  D

 ....S ABSPHRNS=$P($G(^AUPNPAT(ABSPEN,41,ABSPHRN,0)),U,5)  ;inactive?

 ....I (ABSPDEAD=0&ABSPHRN)="I" S ABSPQUIT=1 Q  ;check exclude inactive flag and status

 ....S ABSPSU=$S($P($G(^AUTTLOC(ABSPHRN,0)),U,5)'="":$P($G(^AUTTSU($P($G(^AUTTLOC(ABSPHRN,0)),U,5),0)),U),1:"NO SERVICE UNIT")  ;SU name

 ....S ABSPSUC=$P($G(^AUTTLOC(ABSPHRN,0)),U,13) ;location city

 ....S ABSPSUS=$P($G(^AUTTLOC(ABSPHRN,0)),U,14) ;location state

 ....S ABSPSU(ABSPSU)=ABSPSUC_", "_$S(ABSPSUS'="":$P($G(^DIC(5,ABSPSUS,0)),U,2),1:"")

 ....S ABSPNAM=$P($G(^AUTNINS(ABSPPIEN,0)),U)  ;insurer name

 ....I ($G(^TMP($J,"ABSPOSR7",ABSPSU,ABSPPIEN,ABSPDPT))="") D  ;part D and not on list already

 ..... ; S ABSPPN=$P($G(^AUPNMCR(ABSPEN,11,ABSPEIEN,0)),U,6)  ;ID

 .....S ABSPPN=$$GETMCR^AGUTL(ABSPEN,ABSPELDT)  ;ID ; /IHS/OIT/RAM ; 18 DEC 17 ; new method of retrieving MCRE number / MBI.

 .....S ABSPHRNN=$P($G(^AUPNPAT(ABSPEN,41,ABSPHRN,0)),U,2)  ;HRN

 .....S ^TMP($J,"ABSPOSR7",ABSPSU,ABSPPIEN,ABSPDPT)=ABSPHRNN_U_ABSPSDT_U_ABSPEDT_U_ABSPPN

 .....S ABSPCNT(ABSPSU,ABSPNAM,ABSPPIEN)=+$G(ABSPCNT(ABSPSU,ABSPNAM,ABSPPIEN))+1

 .....S ABSPTOT(ABSPSU,"TOTAL")=+$G(ABSPTOT(ABSPSU,"TOTAL"))+1

 .....S ABSPTOT("TOTAL")=+$G(ABSPTOT("TOTAL"))+1

 ; M ^BZHZ1($J,"ABSPOSR7")=^TMP($J,"ABSPOSR7") ; /IHS/OIT/RAM / TESTING PURPOSES ONLY...

 Q

 ;

PRIVATE(ABSPLIST,ABSPELDT,ABSPDEAD,ABSPCNT,ABSPTOT,ABSPSU)  ;

 N ABSPTIEN,ABSPEN,ABSPNS,ABSPSDT,ABSPEDT,ABSPHRN,ABSPHRNS,ABSPNAM,ABSPHRNN,ABSPPN

 S ABSPTIEN=0

 F  S ABSPTIEN=$O(^AUPNPRVT(ABSPTIEN)) Q:+ABSPTIEN=0  D

 .S ABSPEN=0

 .F  S ABSPEN=$O(^AUPNPRVT(ABSPTIEN,11,ABSPEN)) Q:+ABSPEN=0  D

 ..S ABSPNS=$P($G(^AUPNPRVT(ABSPTIEN,11,ABSPEN,0)),U)

 ..Q:$G(ABSPLIST(ABSPNS))=""  ;not on list

 ..S ABSPSDT=$P($G(^AUPNPRVT(ABSPTIEN,11,ABSPEN,0)),U,6)

 ..S ABSPEDT=$P($G(^AUPNPRVT(ABSPTIEN,11,ABSPEN,0)),U,7)

 ..I ((ABSPSDT=ABSPELDT)!(ABSPSDT<ABSPELDT)),((ABSPEDT>ABSPELDT)!(ABSPEDT="")) D  ;inside date range

 ...S ABSPHRN=0

 ...F  S ABSPHRN=$O(^AUPNPAT(ABSPTIEN,41,ABSPHRN)) Q:+ABSPHRN=0  D

 ....S ABSPHRNS=$P($G(^AUPNPAT(ABSPTIEN,41,ABSPHRN,0)),U,5)  ;inactive?

 ....I ABSPDEAD=0,ABSPHRNS="I" Q  ;check exclude inactive flag and status

 ....S ABSPSU=$S($P($G(^AUTTLOC(ABSPHRN,0)),U,5)'="":$P($G(^AUTTSU($P($G(^AUTTLOC(ABSPHRN,0)),U,5),0)),U),1:"NO SERVICE UNIT")  ;SU name

 ....S ABSPSU(ABSPSU)=$P($G(^AUTTLOC(ABSPHRN,0)),U,13)_", "_$S($P($G(^AUTTLOC(ABSPHRN,0)),U,14)'="":$P($G(^DIC(5,$P($G(^AUTTLOC(ABSPHRN,0)),U,14),0)),U,2),1:"")

 ....S ABSPNAM=$P($G(^AUTNINS(ABSPNS,0)),U)  ;insurer name

 ....I $G(^TMP($J,"ABSPOSR7",ABSPSU,ABSPNS,ABSPTIEN))="" D

 .....S:$P($G(^AUPNPRVT(ABSPTIEN,11,ABSPEN,0)),U,8)'="" ABSPPN=$P($G(^AUPN3PPH($P($G(^AUPNPRVT(ABSPTIEN,11,ABSPEN,0)),U,8),0)),U,4)

 .....S ABSPHRNN=$P($G(^AUPNPAT(ABSPTIEN,41,ABSPHRN,0)),U,2)  ;HRN

 .....S ^TMP($J,"ABSPOSR7",ABSPSU,ABSPNS,ABSPTIEN)=ABSPHRNN_U_ABSPSDT_U_ABSPEDT_U_ABSPPN

 .....S ABSPCNT(ABSPSU,ABSPNAM,ABSPNS)=+$G(ABSPCNT(ABSPSU,ABSPNAM,ABSPNS))+1

 .....S ABSPTOT(ABSPSU,"TOTAL")=+$G(ABSPTOT(ABSPSU,"TOTAL"))+1

 .....S ABSPTOT("TOTAL")=+$G(ABSPTOT("TOTAL"))+1

 Q

 ;

MEDICAID(ABSPLIST,ABSPELDT,ABSPDEAD,ABSPCNT,ABSPTOT,ABSPSU) ;

 N ABSPEN,ABSPEIEN,ABSPCOV,ABSPQUIT,ABSPSDT,ABSPEDT,ABSPHRN,ABSPNAM,ABSPHRNS,ABSPINSN,ABSPHRNN,ABSPPN

 N ABSPPIEN,ABSPPN,ABSPSUC,ABSPSUS,ABSPDPT

 S ABSPEN=0,ABSPQUIT=0

 F  S ABSPEN=$O(^AUPNMCD(ABSPEN)) Q:+ABSPEN=0  D

 .S ABSPDPT=$P(^AUPNMCD(ABSPEN,0),U,1)

 .Q:$G(^DPT(ABSPDPT,0))=""  ;Still have to look out for that...

 .I $D(^DPT(ABSPDPT,.35)),$P(^(.35),U,1)]"",$P(^(.35),U,1)<ABSPELDT Q

 .Q:$G(^AUPNMCD(ABSPEN,0))=""    ;Why would this happen?

 .S ABSPINSP=$P(^AUPNMCD(ABSPEN,0),U,2)  ;POINTER TO INSURER FILE

 .I $P($G(^AUTNINS(ABSPINSP,0)),U,1)="MEDICAID" D

 ..S ABSPSTP=$P($G(^AUPNMCD(ABSPEN,0)),U,4)  ;pointer to the state file

 ..S ABSPMFI=""

 ..S ABSPFND=0

 ..F  S ABSPMFI=$O(^AUTNINS(ABSPINSP,13,ABSPMFI)) Q:(ABSPMFI="")!ABSPFND  D

 ...I $P($G(^AUTNINS(ABSPINSP,13,ABSPMFI,0)),U,1)=ABSPSTP D

 ....S ABSPPIEN=$P($G(^AUTNINS(ABSPINSP,13,ABSPMFI,0)),U,2)

 ....S ABSPFND=1

 .S ABSPEIEN=0

 .F  S ABSPEIEN=$O(^AUPNMCD(ABSPEN,11,ABSPEIEN)) Q:+ABSPEIEN=0  D

 ..I ($G(ABSPPIEN)="") S ABSPQUIT=1 Q

 ..I ($G(ABSPLIST(ABSPPIEN))="") S ABSPQUIT=1 Q  ;no entry for insurer on requested list

 ..I ABSPDEAD=0,($P($G(^DPT(ABSPEN,.35)),U)'="") S ABSPQUIT=1 Q  ;check exclude flag and DOD

 ..S ABSPSDT=$P($G(^AUPNMCD(ABSPEN,11,ABSPEIEN,0)),U) ;ELIG START DATE

 ..S ABSPEDT=$P($G(^AUPNMCD(ABSPEN,11,ABSPEIEN,0)),U,2) ;ELIG END DATE

 ..Q:ABSPSDT=""

 ..I (ABSPSDT<=ABSPELDT)&((ABSPEDT>ABSPELDT)!(ABSPEDT="")) D

 ...S ABSPHRN=0

 ...F  S ABSPHRN=$O(^AUPNPAT(ABSPEN,41,ABSPHRN)) Q:+ABSPHRN=0  D

 ....S ABSPHRNS=$P($G(^AUPNPAT(ABSPEN,41,ABSPHRN,0)),U,5)  ;inactive?

 ....I (ABSPDEAD=0&ABSPHRN)="I" S ABSPQUIT=1 Q  ;check exclude inactive flag and status

 ....S ABSPSU=$S($P($G(^AUTTLOC(ABSPHRN,0)),U,5)'="":$P($G(^AUTTSU($P($G(^AUTTLOC(ABSPHRN,0)),U,5),0)),U),1:"NO SERVICE UNIT")  ;SU name

 ....S ABSPSUC=$P($G(^AUTTLOC(ABSPHRN,0)),U,13) ;location city

 ....S ABSPSUS=$P($G(^AUTTLOC(ABSPHRN,0)),U,14) ;location state

 ....S ABSPSU(ABSPSU)=ABSPSUC_", "_$S(ABSPSUS'="":$P($G(^DIC(5,ABSPSUS,0)),U,2),1:"")

 ....S ABSPNAM=$P($G(^AUTNINS(ABSPPIEN,0)),U)  ;insurer name

 ....;I ($G(^TMP($J,"ABSPOSR7",ABSPSU,ABSPPIEN,ABSPEN))="") D  ;if not already on list...

 ....I ($G(^TMP($J,"ABSPOSR7",ABSPSU,ABSPPIEN,ABSPDPT))="") D  ;if not already on list...

 .....S ABSPPN=$P($G(^AUPNMCD(ABSPEN,0)),U,3)  ;ID

 .....S ABSPHRNN=$P($G(^AUPNPAT(ABSPEN,41,ABSPHRN,0)),U,2)  ;HRN

 .....S ^TMP($J,"ABSPOSR7",ABSPSU,ABSPPIEN,ABSPDPT)=ABSPHRNN_U_ABSPSDT_U_ABSPEDT_U_ABSPPN

 .....S ABSPCNT(ABSPSU,ABSPNAM,ABSPPIEN)=+$G(ABSPCNT(ABSPSU,ABSPNAM,ABSPPIEN))+1

 .....S ABSPTOT(ABSPSU,"TOTAL")=+$G(ABSPTOT(ABSPSU,"TOTAL"))+1

 .....S ABSPTOT("TOTAL")=+$G(ABSPTOT("TOTAL"))+1

 Q

OUTPUT(ABSPTYPE,ABSPELDT,ABSPDTL,ABSPNAME,ABSPCNT,ABSPTOT,ABSPSU) ;

 ;make sure at minimum 0 will print for each insurer selected

 N ABSPIT,ABSPEN,ABSPEIEN,ABSPPIEN,ABSPQUIT,ABSPNAM,ABSPSVC,ABSPPG,ABSPSU2,ABSPSUC,ABSPSUS,ABSPNS

 S ABSPQUIT=0

 S ABSPSVC=""

 F  S ABSPSVC=$O(^TMP($J,"ABSPOSR7",ABSPSVC)) Q:ABSPSVC=""  D

 .S ABSPNAM=""

 .F  S ABSPNAM=$O(ABSPNAME(ABSPNAM)) Q:ABSPNAM=""  D

 ..S ABSPNS=$O(ABSPNAME(ABSPNAM,0))

 ..I '+$G(ABSPCNT(ABSPSVC,ABSPNAM,ABSPNS)) S ABSPCNT(ABSPSVC,ABSPNAM,ABSPNS)=0

 S ABSPSU2=""

 S ABSPSVC=""

 S ABSPPG=0

 D HDR(.ABSPNAME,ABSPELDT,ABSPTYPE,.ABSPPG)

 F  S ABSPSVC=$O(ABSPCNT(ABSPSVC)) Q:ABSPSVC=""  D

 .S ABSPNAM=""

 .F  S ABSPNAM=$O(ABSPCNT(ABSPSVC,ABSPNAM)) Q:ABSPNAM=""  D

 ..S ABSPNS=0

 ..F  S ABSPNS=$O(ABSPCNT(ABSPSVC,ABSPNAM,ABSPNS)) Q:+ABSPNS=0!ABSPQUIT  D

 ...I ABSPSU2=""!(ABSPSU2'=ABSPSVC) D:ABSPPG'=1 HDR(.ABSPNAME,ABSPELDT,ABSPTYPE,.ABSPPG) D SUHDR(ABSPDTL,.ABSPSU,ABSPSVC) S ABSPSU2=ABSPSVC

 ...W !?2,ABSPNAM

 ...W ?53,+$G(ABSPCNT(ABSPSVC,ABSPNAM,ABSPNS))

 ...I $G(ABSPDTL)=1 S ABSPQUIT=$$DETAIL(.ABSPNAME,.ABSPSU,ABSPSVC,ABSPNS,ABSPELDT,ABSPTYPE,.ABSPPG)

 ..W !

 .Q:ABSPQUIT

 .W !!?10,"TOTAL FOR "_ABSPSVC_" SERVICE UNIT: "

 .W ?63,$G(ABSPTOT(ABSPSVC,"TOTAL"))

 D:'ABSPQUIT

 .W !!,?2,"TOTAL NUMBER OF ACTIVE ENROLLEES: "

 .W ?63,+$G(ABSPTOT("TOTAL")),!

 .W !,"(REPORT COMPLETE)",!

 I (IOST[("C-")) Q:ABSPQUIT  Q:$D(IO("S"))  K DIR S DIR(0)="E" D ^DIR S ABSPQUIT=X=U

 K ^TMP($J,"ABSPOSR7")

 Q

 ;

HDR(ABSPNAME,ABSPELDT,ABSPTYPE,ABSPPG)  ;

 N Y,ABSPNAM

 W @IOF

 S ABSPPG=ABSPPG+1

 S Y=DT X ^DD("DD")

 W !,Y,?68,"Page ",ABSPPG

 W !

 S Y=ABSPELDT X ^DD("DD")

 S ABSPNAM=""

 S ABSPNAM=$O(ABSPNAME(ABSPNAM))

 D CENTER("REGISTERED PATIENTS - ACTIVE "_ABSPTYPE_" ENROLLEES")

 I $O(ABSPNAME(ABSPNAM))="" D

 .W !

 .D CENTER(ABSPNAM)

 W !

 S Y=ABSPELDT X ^DD("DD")

 D CENTER("Actively enrolled as of "_Y)

 Q

SUHDR(ABSPDTL,ABSPSU,ABSPSRV)  ;

 W !!?2,"Service Unit: "_ABSPSRV_"  "_$G(ABSPSU(ABSPSRV)),!

 W !?2,"PLAN NAME",?50,"COUNT"

 I $G(ABSPDTL)=1 D

 .W !,?3,"HRN",?15,"SUBSCRIBER NAME",?45,"EFF.DT",?57,"END.DT",?69,"SUBSCR.ID"

 W !,ABSPLINE,!

 Q

CENTER(X)  ;

 S CENTER=IOM/2

 W ?CENTER-($L(X)/2),X

 Q

DETAIL(ABSPNAME,ABSPSU,ABSPSRV,ABSPINS,ABSPELDT,ABSPTYPE,ABSPPG)  ;

 N ABSPPT,ABSPQUIT,Y

 S ABSPPT=0,ABSPQUIT=0

 F  S ABSPPT=$O(^TMP($J,"ABSPOSR7",ABSPSRV,ABSPINS,ABSPPT)) Q:(+ABSPPT=0)!ABSPQUIT  D

 .W !?2,$P($G(^TMP($J,"ABSPOSR7",ABSPSRV,ABSPINS,ABSPPT)),U)

 .W ?13,$P($G(^DPT(ABSPPT,0)),U)

 .S Y=$P($G(^TMP($J,"ABSPOSR7",ABSPSRV,ABSPINS,ABSPPT)),U,2)

 .X ^DD("DD")

 .W ?42,Y

 .S Y=$P($G(^TMP($J,"ABSPOSR7",ABSPSRV,ABSPINS,ABSPPT)),U,3)

 .X ^DD("DD")

 .W ?54,Y

 .W ?70,$P($G(^TMP($J,"ABSPOSR7",ABSPSRV,ABSPINS,ABSPPT)),U,4)

 .I (IOST[("C-")),(($Y>IOSL)!($Y=IOSL)) D

 ..Q:ABSPQUIT

 ..Q:$D(IO("S"))

 ..K DIR

 ..S DIR(0)="E"

 ..D ^DIR

 ..S ABSPQUIT=X=U

 ..Q:ABSPQUIT

 ..D HDR(.ABSPNAME,ABSPELDT,ABSPTYPE,.ABSPPG),SUHDR(1,.ABSPSU,ABSPSRV)

 Q ABSPQUIT

DEVSEL ; SELECT DEVICE

 N ABSPSTOP

 S ABSPSTOP=0

 D ^%ZIS

 I POP D ^%ZIS

 I $D(DUOUT) D

  .D ^%ZISC

  .S ABSPSTOP=1

 Q:ABSPSTOP

 I POP D

 .W "DEVICE UNAVAILABLE" G DEVSEL

 Q

 ;

ABSPOSR7  ;IHS/OIT/SCR - POS Insurance Report ;

 +1       ;;1.0;PHARMACY POINT OF SALE;**38,50**;JUN 01, 2001  ;Build 38

 +2       ;;

 +3       ;;BASED ON FILE ABMRMCRD - 2.6;IHS 3P BILLING SYSTEM;;NOV 12, 2009

 +4        QUIT 

EN        ;ENTRY POINT from ABSP RPT INSURER REPORT

 +1        NEW ABSPLINE,ABSPINS,ABSPLIST,ABSPTYPE,ABSPTYPI,ABSPELDT,ABSPDEAD,ABSPDTL

 +2        NEW ABSPCNT,ABSPTOT,ABSPSU,ABSPNAME

 +3        SET $PIECE(ABSPLINE,"-",79)="-"

 +4       ;message about report

           DO MESSAGE

 +5        SET ABSPDTL=0

 +6        SET ABSPTYPE=$$INSTYPE()

 +7        IF ABSPTYPE=-1

               QUIT 

 +8        SET ABSPTYPI=$PIECE(ABSPTYPE,":",1)

 +9        SET ABSPTYPE=$PIECE(ABSPTYPE,":",2)

 +10       SET ABSPINS=$$INS(ABSPTYPI)

 +11       IF ABSPINS=-1

               QUIT 

 +12       WRITE !,"Reporting For Insurance Type: "_ABSPTYPE

 +13      ;get list of insurers we're looking for

           DO GETINS(ABSPINS,ABSPTYPI,.ABSPLIST,.ABSPNAME)

 +14      ;display list

           DO DISP(.ABSPNAME)

 +15      ;get list for what date?

           SET ABSPELDT=$$ELIGDT()

 +16       IF ABSPELDT=-1

               QUIT 

 +17      ;include inactive/deceased pts?

           SET ABSPDEAD=$$INACT()

 +18       IF ABSPDEAD=-1

               QUIT 

 +19       IF ABSPINS=""

 +20      ;detail?

           IF ABSPINS'="ALL"

               SET ABSPDTL=$$DETAILQ()

 +21       IF ABSPDTL=-1

               QUIT 

 +22       DO DEVSEL

 +23       WRITE !,"Gathering data...",!

 +24      ;go count data

           DO COUNTIT(.ABSPLIST,ABSPTYPE,ABSPELDT,ABSPDEAD,.ABSPCNT,.ABSPTOT,.ABSPSU)

 +25       DO OUTPUT(ABSPTYPE,ABSPELDT,ABSPDTL,.ABSPNAME,.ABSPCNT,.ABSPTOT,.ABSPSU)

 +26       QUIT 

 +27      ;

MESSAGE   ;

 +1        WRITE !?2,"This option will print information about the number of registered patients"

 +2        WRITE !?2,"who are currently enrolled in an insurance type that you will select."

 +3        WRITE !?2,"You will be asked if you wish to include only active patients."

 +4        WRITE !?2,"You will be asked to select a particular POS insurance company of the type selected"

 +5        WRITE !?2,"PATIENT DETAIL can be selected unless ALL insurance companies are specified"

 +6        WRITE !!?2,"You will be asked to enter an ""As of"" date to be used in determining"

 +7        WRITE !?2,"those patients who are ""actively"" enrolled in a plan of the selected type."

 +8        QUIT 

 +9       ;

INSTYPE() ;SELECT THE TYPE OF INSURER TO REPORT ON

 +1        NEW DIX,X,Y

 +2        SET DIR(0)="SX^D:MEDICAID FI;P:PRIVATE;MD:MEDICARE PART D"

 +3        SET DIR("B")="MD"

 +4        SET DIR("A")="SELECT INSURER TYPE"

 +5        DO ^DIR

 +6        IF $DATA(DUOUT)!$DATA(DIROUT)!$DATA(DIRUT)!$DATA(DTOUT)

               QUIT -1

 +7        QUIT X_":"_$GET(Y(0))

 +8       ;

INS(ABSPTYPE) ; SELECT THE INSURER OR CHOOSE ALL INSURERS

 +1        NEW DIC,X,Y,ABSPINS

 +2        SET DIC(0)="AEMNQZ"

 +3        SET DIC("A")="Please choose an insurer or leave blank for ALL: "

 +4        SET DIC="^ABSPEI("

 +5        SET DIC("S")="I $P(^AUTNINS($P($G(^ABSPEI(Y,0)),U,1),2),U,1)="""_ABSPTYPE_""""

 +6        DO ^DIC

           KILL DIC

 +7        IF $DATA(DUOUT)!$DATA(DIROUT)!$DATA(DIRUT)!$DATA(DTOUT)

               QUIT -1

 +8        IF Y=-1

               SET ABSPINS="ALL"

 +9       ;,ABSPINSN=$P(Y,"^",2)

           IF Y'=-1

               SET ABSPINS=$PIECE(Y,"^",1)

 +10       QUIT ABSPINS

 +11      ;

GETINS(ABSPINS,ABSPTYPE,ABSPLIST,ABSPNAME) ;RETURN info on specified insurer or all of identified type

 +1       ;

 +2        NEW ABSPNAM,ABSPNS

 +3        SET ABSPNS=0

 +4        IF ABSPINS="ALL"

               Begin DoDot:1

 +5                FOR 

                       SET ABSPNS=$ORDER(^ABSPEI(ABSPNS))

                       IF +ABSPNS=0

                           QUIT 

                       Begin DoDot:2

 +6                        IF $PIECE(^AUTNINS($PIECE($GET(^ABSPEI(ABSPNS,0)),U,1),2),U,1)=ABSPTYPE

                               Begin DoDot:3

 +7                                SET ABSPNAM=$PIECE($GET(^AUTNINS(ABSPNS,0)),U)

 +8                                SET ABSPLIST(ABSPNS)=ABSPNAM

 +9                                SET ABSPNAME(ABSPNAM,ABSPNS)=""

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +10       IF ABSPINS'="ALL"

               Begin DoDot:1

 +11               SET ABSPNAM=$PIECE($GET(^AUTNINS(ABSPINS,0)),U)

 +12               SET ABSPLIST(ABSPINS)=ABSPNAM

 +13               SET ABSPNAME(ABSPNAM,ABSPINS)=""

               End DoDot:1

 +14       QUIT 

 +15      ;

DISP(ABSPNAME) ;display list of insurers

 +1        NEW ABSPNAM

 +2        WRITE !,"     The following POS Insurer(s) will be included on this report:"

 +3        SET ABSPNAM=""

 +4        IF $ORDER(ABSPNAME(""))=""

               WRITE !,"No POS Insurers Found"

               QUIT 

 +5        FOR 

               SET ABSPNAM=$ORDER(ABSPNAME(ABSPNAM))

               IF ABSPNAM=""

                   QUIT 

               WRITE !,"  "_ABSPNAM

 +6        QUIT 

 +7       ;

ELIGDT()  ;get list for what date-default to today

 +1        NEW ABSPELDT

 +2        WRITE !

 +3        KILL DIR,DIC,DIE,X,Y,DR

 +4        SET DIR(0)="D"

 +5        SET DIR("A")="Display eligibility as of what date?"

 +6        SET DIR("B")="Today"

 +7        DO ^DIR

 +8        KILL DIR

 +9        IF $DATA(DUOUT)!$DATA(DIROUT)!$DATA(DIRUT)!$DATA(DTOUT)

               QUIT -1

 +10       SET ABSPELDT=+Y

 +11      ;display date selected

           WRITE "  ("_Y(0)_")"

 +12       QUIT ABSPELDT

 +13      ;

INACT()   ;include inactive/deceased pts?

 +1        WRITE !

 +2        NEW DIR,DIC,DIE,X,Y,DR,ABSPALL

 +3        SET DIR(0)="Y"

 +4        SET DIR("A")="Do you wish to EXCLUDE inactive and deceased patients"

 +5        SET DIR("B")="YES"

 +6        DO ^DIR

 +7        IF $DATA(DUOUT)!$DATA(DIROUT)!$DATA(DIRUT)!$DATA(DTOUT)

               QUIT -1

 +8       ;exclude

           IF Y=1

               SET ABSPALL=0

 +9       ;include all patients

          IF '$TEST

               SET ABSPALL=1

 +10       QUIT ABSPALL

DETAILQ() ;

 +1        WRITE !

 +2        NEW DIR,DIC,DIE,X,Y,DR,ABSPDTL

 +3        SET DIR(0)="Y"

 +4        SET DIR("A")="Do you wish to view detail (patients)"

 +5        SET DIR("B")="NO"

 +6        DO ^DIR

 +7        IF $DATA(DUOUT)!$DATA(DIROUT)!$DATA(DIRUT)!$DATA(DTOUT)

               QUIT -1

 +8       ;detail

           IF Y=1

               SET ABSPDTL=1

 +9       ;summary

          IF '$TEST

               SET ABSPDTL=0

 +10       QUIT ABSPDTL

 +11      ;

COUNTIT(ABSPLIST,ABSPTYPE,ABSPELDT,ABSPDEAD,ABSPCNT,ABSPTOT,ABSPSU) ;do counts for selected insurers

 +1        IF (ABSPTYPE="MEDICAID FI")

               DO MEDICAID(.ABSPLIST,ABSPELDT,ABSPDEAD,.ABSPCNT,.ABSPTOT,.ABSPSU)

 +2        IF (ABSPTYPE="PRIVATE")

               DO PRIVATE(.ABSPLIST,ABSPELDT,ABSPDEAD,.ABSPCNT,.ABSPTOT,.ABSPSU)

 +3        IF (ABSPTYPE="MEDICARE PART D")

               DO MEDICARE(.ABSPLIST,ABSPELDT,ABSPDEAD,.ABSPCNT,.ABSPTOT,.ABSPSU)

 +4        QUIT 

 +5       ;

MEDICARE(ABSPLIST,ABSPELDT,ABSPDEAD,ABSPCNT,ABSPTOT,ABSPSU) ;

 +1        NEW ABSPEN,ABSPEIEN,ABSPCOV,ABSPQUIT,ABSPSDT,ABSPEDT,ABSPHRN,ABSPNAM,ABSPHRNS,ABSPPIEN,ABSPHRNN

 +2        NEW ABSPPN,ABSPSUC,ABSPSUS,ABSPDPT

 +3        SET ABSPEN=0

           SET ABSPQUIT=0

 +4        FOR 

               SET ABSPEN=$ORDER(^AUPNMCR(ABSPEN))

               IF +ABSPEN=0

                   QUIT 

               Begin DoDot:1

 +5                SET ABSPDPT=$PIECE(^AUPNMCR(ABSPEN,0),U,1)

 +6       ;Still have to look out for that...

                   IF $GET(^DPT(ABSPDPT,0))=""

                       QUIT 

 +7                IF $DATA(^DPT(ABSPDPT,.35))

                       IF $PIECE(^(.35),U,1)]""

                           IF $PIECE(^(.35),U,1)<ABSPELDT

                               QUIT 

 +8                SET ABSPEIEN=0

 +9                FOR 

                       SET ABSPEIEN=$ORDER(^AUPNMCR(ABSPEN,11,ABSPEIEN))

                       IF +ABSPEIEN=0

                           QUIT 

                       Begin DoDot:2

 +10      ;coverage type

                           SET ABSPCOV=$PIECE($GET(^AUPNMCR(ABSPEN,11,ABSPEIEN,0)),U,3)

 +11                       IF ABSPCOV'="D"

                               QUIT 

 +12      ; plan name (pointer to ins file)

                           SET ABSPPIEN=$PIECE($GET(^AUPNMCR(ABSPEN,11,ABSPEIEN,0)),U,4)

 +13                       IF ($GET(ABSPPIEN)="")

                               SET ABSPQUIT=1

                               QUIT 

 +14      ;no entry for insurer on requested list

                           IF ($GET(ABSPLIST(ABSPPIEN))="")

                               SET ABSPQUIT=1

                               QUIT 

 +15      ;check exclude flag and DOD

                           IF ABSPDEAD=0

                               IF ($PIECE($GET(^DPT(ABSPEN,.35)),U)'="")

                                   SET ABSPQUIT=1

                                   QUIT 

 +16      ;ELIG START DATE

                           SET ABSPSDT=$PIECE($GET(^AUPNMCR(ABSPEN,11,ABSPEIEN,0)),U)

 +17      ;ELIG END DATE

                           SET ABSPEDT=$PIECE($GET(^AUPNMCR(ABSPEN,11,ABSPEIEN,0)),U,2)

 +18                       IF (ABSPSDT<=ABSPELDT)&((ABSPEDT>ABSPELDT)!(ABSPEDT=""))

                               Begin DoDot:3

 +19                               SET ABSPHRN=0

 +20                               FOR