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
SET ABSPHRN=$ORDER(^AUPNPAT(ABSPEN,41,ABSPHRN))
IF +ABSPHRN=0
QUIT
Begin DoDot:4
+21 ;inactive?
SET ABSPHRNS=$PIECE($GET(^AUPNPAT(ABSPEN,41,ABSPHRN,0)),U,5)
+22 ;check exclude inactive flag and status
IF (ABSPDEAD=0&ABSPHRN)="I"
SET ABSPQUIT=1
QUIT
+23 ;SU name
SET ABSPSU=$SELECT($PIECE($GET(^AUTTLOC(ABSPHRN,0)),U,5)'="":$PIECE($GET(^AUTTSU($PIECE($GET(^AUTTLOC(ABSPHRN,0)),U,5),0)),U),1:"NO SERVICE UNIT")
+24 ;location city
SET ABSPSUC=$PIECE($GET(^AUTTLOC(ABSPHRN,0)),U,13)
+25 ;location state
SET ABSPSUS=$PIECE($GET(^AUTTLOC(ABSPHRN,0)),U,14)
+26 SET ABSPSU(ABSPSU)=ABSPSUC_", "_$SELECT(ABSPSUS'="":$PIECE($GET(^DIC(5,ABSPSUS,0)),U,2),1:"")
+27 ;insurer name
SET ABSPNAM=$PIECE($GET(^AUTNINS(ABSPPIEN,0)),U)
+28 ;part D and not on list already
IF ($GET(^TMP($JOB,"ABSPOSR7",ABSPSU,ABSPPIEN,ABSPDPT))="")
Begin DoDot:5
+29 ; S ABSPPN=$P($G(^AUPNMCR(ABSPEN,11,ABSPEIEN,0)),U,6) ;ID
+30 ;ID ; /IHS/OIT/RAM ; 18 DEC 17 ; new method of retrieving MCRE number / MBI.
SET ABSPPN=$$GETMCR^AGUTL(ABSPEN,ABSPELDT)
+31 ;HRN
SET ABSPHRNN=$PIECE($GET(^AUPNPAT(ABSPEN,41,ABSPHRN,0)),U,2)
+32 SET ^TMP($JOB,"ABSPOSR7",ABSPSU,ABSPPIEN,ABSPDPT)=ABSPHRNN_U_ABSPSDT_U_ABSPEDT_U_ABSPPN
+33 SET ABSPCNT(ABSPSU,ABSPNAM,ABSPPIEN)=+$GET(ABSPCNT(ABSPSU,ABSPNAM,ABSPPIEN))+1
+34 SET ABSPTOT(ABSPSU,"TOTAL")=+$GET(ABSPTOT(ABSPSU,"TOTAL"))+1
+35 SET ABSPTOT("TOTAL")=+$GET(ABSPTOT("TOTAL"))+1
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+36 ; M ^BZHZ1($J,"ABSPOSR7")=^TMP($J,"ABSPOSR7") ; /IHS/OIT/RAM / TESTING PURPOSES ONLY...
+37 QUIT
+38 ;
PRIVATE(ABSPLIST,ABSPELDT,ABSPDEAD,ABSPCNT,ABSPTOT,ABSPSU) ;
+1 NEW ABSPTIEN,ABSPEN,ABSPNS,ABSPSDT,ABSPEDT,ABSPHRN,ABSPHRNS,ABSPNAM,ABSPHRNN,ABSPPN
+2 SET ABSPTIEN=0
+3 FOR
SET ABSPTIEN=$ORDER(^AUPNPRVT(ABSPTIEN))
IF +ABSPTIEN=0
QUIT
Begin DoDot:1
+4 SET ABSPEN=0
+5 FOR
SET ABSPEN=$ORDER(^AUPNPRVT(ABSPTIEN,11,ABSPEN))
IF +ABSPEN=0
QUIT
Begin DoDot:2
+6 SET ABSPNS=$PIECE($GET(^AUPNPRVT(ABSPTIEN,11,ABSPEN,0)),U)
+7 ;not on list
IF $GET(ABSPLIST(ABSPNS))=""
QUIT
+8 SET ABSPSDT=$PIECE($GET(^AUPNPRVT(ABSPTIEN,11,ABSPEN,0)),U,6)
+9 SET ABSPEDT=$PIECE($GET(^AUPNPRVT(ABSPTIEN,11,ABSPEN,0)),U,7)
+10 ;inside date range
IF ((ABSPSDT=ABSPELDT)!(ABSPSDT<ABSPELDT))
IF ((ABSPEDT>ABSPELDT)!(ABSPEDT=""))
Begin DoDot:3
+11 SET ABSPHRN=0
+12 FOR
SET ABSPHRN=$ORDER(^AUPNPAT(ABSPTIEN,41,ABSPHRN))
IF +ABSPHRN=0
QUIT
Begin DoDot:4
+13 ;inactive?
SET ABSPHRNS=$PIECE($GET(^AUPNPAT(ABSPTIEN,41,ABSPHRN,0)),U,5)
+14 ;check exclude inactive flag and status
IF ABSPDEAD=0
IF ABSPHRNS="I"
QUIT
+15 ;SU name
SET ABSPSU=$SELECT($PIECE($GET(^AUTTLOC(ABSPHRN,0)),U,5)'="":$PIECE($GET(^AUTTSU($PIECE($GET(^AUTTLOC(ABSPHRN,0)),U,5),0)),U),1:"NO SERVICE UNIT")
+16 SET ABSPSU(ABSPSU)=$PIECE($GET(^AUTTLOC(ABSPHRN,0)),U,13)_", "_$SELECT($PIECE($GET(^AUTTLOC(ABSPHRN,0)),U,14)'="":$PIECE($GET(^DIC(5,$PIECE($GET(^AUTTLOC(ABSPHRN,0)),U,14),0)),U,2),1:"")
+17 ;insurer name
SET ABSPNAM=$PIECE($GET(^AUTNINS(ABSPNS,0)),U)
+18 IF $GET(^TMP($JOB,"ABSPOSR7",ABSPSU,ABSPNS,ABSPTIEN))=""
Begin DoDot:5
+19 IF $PIECE($GET(^AUPNPRVT(ABSPTIEN,11,ABSPEN,0)),U,8)'=""
SET ABSPPN=$PIECE($GET(^AUPN3PPH($PIECE($GET(^AUPNPRVT(ABSPTIEN,11,ABSPEN,0)),U,8),0)),U,4)
+20 ;HRN
SET ABSPHRNN=$PIECE($GET(^AUPNPAT(ABSPTIEN,41,ABSPHRN,0)),U,2)
+21 SET ^TMP($JOB,"ABSPOSR7",ABSPSU,ABSPNS,ABSPTIEN)=ABSPHRNN_U_ABSPSDT_U_ABSPEDT_U_ABSPPN
+22 SET ABSPCNT(ABSPSU,ABSPNAM,ABSPNS)=+$GET(ABSPCNT(ABSPSU,ABSPNAM,ABSPNS))+1
+23 SET ABSPTOT(ABSPSU,"TOTAL")=+$GET(ABSPTOT(ABSPSU,"TOTAL"))+1
+24 SET ABSPTOT("TOTAL")=+$GET(ABSPTOT("TOTAL"))+1
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+25 QUIT
+26 ;
MEDICAID(ABSPLIST,ABSPELDT,ABSPDEAD,ABSPCNT,ABSPTOT,ABSPSU) ;
+1 NEW ABSPEN,ABSPEIEN,ABSPCOV,ABSPQUIT,ABSPSDT,ABSPEDT,ABSPHRN,ABSPNAM,ABSPHRNS,ABSPINSN,ABSPHRNN,ABSPPN
+2 NEW ABSPPIEN,ABSPPN,ABSPSUC,ABSPSUS,ABSPDPT
+3 SET ABSPEN=0
SET ABSPQUIT=0
+4 FOR
SET ABSPEN=$ORDER(^AUPNMCD(ABSPEN))
IF +ABSPEN=0
QUIT
Begin DoDot:1
+5 SET ABSPDPT=$PIECE(^AUPNMCD(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 ;Why would this happen?
IF $GET(^AUPNMCD(ABSPEN,0))=""
QUIT
+9 ;POINTER TO INSURER FILE
SET ABSPINSP=$PIECE(^AUPNMCD(ABSPEN,0),U,2)
+10 IF $PIECE($GET(^AUTNINS(ABSPINSP,0)),U,1)="MEDICAID"
Begin DoDot:2
+11 ;pointer to the state file
SET ABSPSTP=$PIECE($GET(^AUPNMCD(ABSPEN,0)),U,4)
+12 SET ABSPMFI=""
+13 SET ABSPFND=0
+14 FOR
SET ABSPMFI=$ORDER(^AUTNINS(ABSPINSP,13,ABSPMFI))
IF (ABSPMFI="")!ABSPFND
QUIT
Begin DoDot:3
+15 IF $PIECE($GET(^AUTNINS(ABSPINSP,13,ABSPMFI,0)),U,1)=ABSPSTP
Begin DoDot:4
+16 SET ABSPPIEN=$PIECE($GET(^AUTNINS(ABSPINSP,13,ABSPMFI,0)),U,2)
+17 SET ABSPFND=1
End DoDot:4
End DoDot:3
End DoDot:2
+18 SET ABSPEIEN=0
+19 FOR
SET ABSPEIEN=$ORDER(^AUPNMCD(ABSPEN,11,ABSPEIEN))
IF +ABSPEIEN=0
QUIT
Begin DoDot:2
+20 IF ($GET(ABSPPIEN)="")
SET ABSPQUIT=1
QUIT
+21 ;no entry for insurer on requested list
IF ($GET(ABSPLIST(ABSPPIEN))="")
SET ABSPQUIT=1
QUIT
+22 ;check exclude flag and DOD
IF ABSPDEAD=0
IF ($PIECE($GET(^DPT(ABSPEN,.35)),U)'="")
SET ABSPQUIT=1
QUIT
+23 ;ELIG START DATE
SET ABSPSDT=$PIECE($GET(^AUPNMCD(ABSPEN,11,ABSPEIEN,0)),U)
+24 ;ELIG END DATE
SET ABSPEDT=$PIECE($GET(^AUPNMCD(ABSPEN,11,ABSPEIEN,0)),U,2)
+25 IF ABSPSDT=""
QUIT
+26 IF (ABSPSDT<=ABSPELDT)&((ABSPEDT>ABSPELDT)!(ABSPEDT=""))
Begin DoDot:3
+27 SET ABSPHRN=0
+28 FOR
SET ABSPHRN=$ORDER(^AUPNPAT(ABSPEN,41,ABSPHRN))
IF +ABSPHRN=0
QUIT
Begin DoDot:4
+29 ;inactive?
SET ABSPHRNS=$PIECE($GET(^AUPNPAT(ABSPEN,41,ABSPHRN,0)),U,5)
+30 ;check exclude inactive flag and status
IF (ABSPDEAD=0&ABSPHRN)="I"
SET ABSPQUIT=1
QUIT
+31 ;SU name
SET ABSPSU=$SELECT($PIECE($GET(^AUTTLOC(ABSPHRN,0)),U,5)'="":$PIECE($GET(^AUTTSU($PIECE($GET(^AUTTLOC(ABSPHRN,0)),U,5),0)),U),1:"NO SERVICE UNIT")
+32 ;location city
SET ABSPSUC=$PIECE($GET(^AUTTLOC(ABSPHRN,0)),U,13)
+33 ;location state
SET ABSPSUS=$PIECE($GET(^AUTTLOC(ABSPHRN,0)),U,14)
+34 SET ABSPSU(ABSPSU)=ABSPSUC_", "_$SELECT(ABSPSUS'="":$PIECE($GET(^DIC(5,ABSPSUS,0)),U,2),1:"")
+35 ;insurer name
SET ABSPNAM=$PIECE($GET(^AUTNINS(ABSPPIEN,0)),U)
+36 ;I ($G(^TMP($J,"ABSPOSR7",ABSPSU,ABSPPIEN,ABSPEN))="") D ;if not already on list...
+37 ;if not already on list...
IF ($GET(^TMP($JOB,"ABSPOSR7",ABSPSU,ABSPPIEN,ABSPDPT))="")
Begin DoDot:5
+38 ;ID
SET ABSPPN=$PIECE($GET(^AUPNMCD(ABSPEN,0)),U,3)
+39 ;HRN
SET ABSPHRNN=$PIECE($GET(^AUPNPAT(ABSPEN,41,ABSPHRN,0)),U,2)
+40 SET ^TMP($JOB,"ABSPOSR7",ABSPSU,ABSPPIEN,ABSPDPT)=ABSPHRNN_U_ABSPSDT_U_ABSPEDT_U_ABSPPN
+41 SET ABSPCNT(ABSPSU,ABSPNAM,ABSPPIEN)=+$GET(ABSPCNT(ABSPSU,ABSPNAM,ABSPPIEN))+1
+42 SET ABSPTOT(ABSPSU,"TOTAL")=+$GET(ABSPTOT(ABSPSU,"TOTAL"))+1
+43 SET ABSPTOT("TOTAL")=+$GET(ABSPTOT("TOTAL"))+1
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+44 QUIT
OUTPUT(ABSPTYPE,ABSPELDT,ABSPDTL,ABSPNAME,ABSPCNT,ABSPTOT,ABSPSU) ;
+1 ;make sure at minimum 0 will print for each insurer selected
+2 NEW ABSPIT,ABSPEN,ABSPEIEN,ABSPPIEN,ABSPQUIT,ABSPNAM,ABSPSVC,ABSPPG,ABSPSU2,ABSPSUC,ABSPSUS,ABSPNS
+3 SET ABSPQUIT=0
+4 SET ABSPSVC=""
+5 FOR
SET ABSPSVC=$ORDER(^TMP($JOB,"ABSPOSR7",ABSPSVC))
IF ABSPSVC=""
QUIT
Begin DoDot:1
+6 SET ABSPNAM=""
+7 FOR
SET ABSPNAM=$ORDER(ABSPNAME(ABSPNAM))
IF ABSPNAM=""
QUIT
Begin DoDot:2
+8 SET ABSPNS=$ORDER(ABSPNAME(ABSPNAM,0))
+9 IF '+$GET(ABSPCNT(ABSPSVC,ABSPNAM,ABSPNS))
SET ABSPCNT(ABSPSVC,ABSPNAM,ABSPNS)=0
End DoDot:2
End DoDot:1
+10 SET ABSPSU2=""
+11 SET ABSPSVC=""
+12 SET ABSPPG=0
+13 DO HDR(.ABSPNAME,ABSPELDT,ABSPTYPE,.ABSPPG)
+14 FOR
SET ABSPSVC=$ORDER(ABSPCNT(ABSPSVC))
IF ABSPSVC=""
QUIT
Begin DoDot:1
+15 SET ABSPNAM=""
+16 FOR
SET ABSPNAM=$ORDER(ABSPCNT(ABSPSVC,ABSPNAM))
IF ABSPNAM=""
QUIT
Begin DoDot:2
+17 SET ABSPNS=0
+18 FOR
SET ABSPNS=$ORDER(ABSPCNT(ABSPSVC,ABSPNAM,ABSPNS))
IF +ABSPNS=0!ABSPQUIT
QUIT
Begin DoDot:3
+19 IF ABSPSU2=""!(ABSPSU2'=ABSPSVC)
IF ABSPPG'=1
DO HDR(.ABSPNAME,ABSPELDT,ABSPTYPE,.ABSPPG)
DO SUHDR(ABSPDTL,.ABSPSU,ABSPSVC)
SET ABSPSU2=ABSPSVC
+20 WRITE !?2,ABSPNAM
+21 WRITE ?53,+$GET(ABSPCNT(ABSPSVC,ABSPNAM,ABSPNS))
+22 IF $GET(ABSPDTL)=1
SET ABSPQUIT=$$DETAIL(.ABSPNAME,.ABSPSU,ABSPSVC,ABSPNS,ABSPELDT,ABSPTYPE,.ABSPPG)
End DoDot:3
+23 WRITE !
End DoDot:2
+24 IF ABSPQUIT
QUIT
+25 WRITE !!?10,"TOTAL FOR "_ABSPSVC_" SERVICE UNIT: "
+26 WRITE ?63,$GET(ABSPTOT(ABSPSVC,"TOTAL"))
End DoDot:1
+27 IF 'ABSPQUIT
Begin DoDot:1
+28 WRITE !!,?2,"TOTAL NUMBER OF ACTIVE ENROLLEES: "
+29 WRITE ?63,+$GET(ABSPTOT("TOTAL")),!
+30 WRITE !,"(REPORT COMPLETE)",!
End DoDot:1
+31 IF (IOST[("C-"))
IF ABSPQUIT
QUIT
IF $DATA(IO("S"))
QUIT
KILL DIR
SET DIR(0)="E"
DO ^DIR
SET ABSPQUIT=X=U
+32 KILL ^TMP($JOB,"ABSPOSR7")
+33 QUIT
+34 ;
HDR(ABSPNAME,ABSPELDT,ABSPTYPE,ABSPPG) ;
+1 NEW Y,ABSPNAM
+2 WRITE @IOF
+3 SET ABSPPG=ABSPPG+1
+4 SET Y=DT
XECUTE ^DD("DD")
+5 WRITE !,Y,?68,"Page ",ABSPPG
+6 WRITE !
+7 SET Y=ABSPELDT
XECUTE ^DD("DD")
+8 SET ABSPNAM=""
+9 SET ABSPNAM=$ORDER(ABSPNAME(ABSPNAM))
+10 DO CENTER("REGISTERED PATIENTS - ACTIVE "_ABSPTYPE_" ENROLLEES")
+11 IF $ORDER(ABSPNAME(ABSPNAM))=""
Begin DoDot:1
+12 WRITE !
+13 DO CENTER(ABSPNAM)
End DoDot:1
+14 WRITE !
+15 SET Y=ABSPELDT
XECUTE ^DD("DD")
+16 DO CENTER("Actively enrolled as of "_Y)
+17 QUIT
SUHDR(ABSPDTL,ABSPSU,ABSPSRV) ;
+1 WRITE !!?2,"Service Unit: "_ABSPSRV_" "_$GET(ABSPSU(ABSPSRV)),!
+2 WRITE !?2,"PLAN NAME",?50,"COUNT"
+3 IF $GET(ABSPDTL)=1
Begin DoDot:1
+4 WRITE !,?3,"HRN",?15,"SUBSCRIBER NAME",?45,"EFF.DT",?57,"END.DT",?69,"SUBSCR.ID"
End DoDot:1
+5 WRITE !,ABSPLINE,!
+6 QUIT
CENTER(X) ;
+1 SET CENTER=IOM/2
+2 WRITE ?CENTER-($LENGTH(X)/2),X
+3 QUIT
DETAIL(ABSPNAME,ABSPSU,ABSPSRV,ABSPINS,ABSPELDT,ABSPTYPE,ABSPPG) ;
+1 NEW ABSPPT,ABSPQUIT,Y
+2 SET ABSPPT=0
SET ABSPQUIT=0
+3 FOR
SET ABSPPT=$ORDER(^TMP($JOB,"ABSPOSR7",ABSPSRV,ABSPINS,ABSPPT))
IF (+ABSPPT=0)!ABSPQUIT
QUIT
Begin DoDot:1
+4 WRITE !?2,$PIECE($GET(^TMP($JOB,"ABSPOSR7",ABSPSRV,ABSPINS,ABSPPT)),U)
+5 WRITE ?13,$PIECE($GET(^DPT(ABSPPT,0)),U)
+6 SET Y=$PIECE($GET(^TMP($JOB,"ABSPOSR7",ABSPSRV,ABSPINS,ABSPPT)),U,2)
+7 XECUTE ^DD("DD")
+8 WRITE ?42,Y
+9 SET Y=$PIECE($GET(^TMP($JOB,"ABSPOSR7",ABSPSRV,ABSPINS,ABSPPT)),U,3)
+10 XECUTE ^DD("DD")
+11 WRITE ?54,Y
+12 WRITE ?70,$PIECE($GET(^TMP($JOB,"ABSPOSR7",ABSPSRV,ABSPINS,ABSPPT)),U,4)
+13 IF (IOST[("C-"))
IF (($Y>IOSL)!($Y=IOSL))
Begin DoDot:2
+14 IF ABSPQUIT
QUIT
+15 IF $DATA(IO("S"))
QUIT
+16 KILL DIR
+17 SET DIR(0)="E"
+18 DO ^DIR
+19 SET ABSPQUIT=X=U
+20 IF ABSPQUIT
QUIT
+21 DO HDR(.ABSPNAME,ABSPELDT,ABSPTYPE,.ABSPPG)
DO SUHDR(1,.ABSPSU,ABSPSRV)
End DoDot:2
End DoDot:1
+22 QUIT ABSPQUIT
DEVSEL ; SELECT DEVICE
+1 NEW ABSPSTOP
+2 SET ABSPSTOP=0
+3 DO ^%ZIS
+4 IF POP
DO ^%ZIS
+5 IF $DATA(DUOUT)
Begin DoDot:1
+6 DO ^%ZISC
+7 SET ABSPSTOP=1
End DoDot:1
+8 IF ABSPSTOP
QUIT
+9 IF POP
Begin DoDot:1
+10 WRITE "DEVICE UNAVAILABLE"
GOTO DEVSEL
End DoDot:1
+11 QUIT
+12 ;
