ABSPOSR5.m

ABSPOSR5  ;IHS/OIT/SCR - REJECTION REPORT BY REJECTION REASON

 ;;1.0;PHARMACY POINT OF SALE;**29,30,34,35,39,40**;JUN 21, 2001;Build 38

 ; DISPLAYS POS CLAIMS BY REJECT CODE

 ; PATCH 40 NOTES: This routine was removed from POS MENUs and replaced with routine ABSPOSRY which does not use

 ;  ABSP REPORT MASTER file or the ^ABSPT("NON-FILEMAN" cross-reference. It is staying with the build for comparison

 ;  

UPD ; UPDATE THE REPORT MASTER FILE IN ABSP

 N ABSPQUIT,ABSPDONE,ABSPSTRT,ABSPEND,ABSPLCNT

 ;D AUTO^ABSPOSM1()    ;IHS/OIT/CNI/SCR patch 40 - can't run this from the prompt

 I $D(ZTQPARAM) D START

 S ABSPDONE=0

 S ABSPQUIT=0

 F  Q:ABSPDONE=1  D

 .S ABSPSTRT=$$BDT()

 .I ABSPSTRT=-1 D

 ..S ABSPQUIT=1

 ..S ABSPDONE=1

 .Q:ABSPQUIT

 .S ABSPEND=$$EDT()

 .I ABSPEND=-1 D

 ..S ABSPQUIT=1

 ..S ABSPDONE=1

 .Q:ABSPQUIT

 .I ABSPSTRT<0 S ABSPDONE=1 Q

 .I ABSPEND<0 S ABSPDONE=1 Q

 .S X2=ABSPSTRT,X1=ABSPEND D ^%DTC

 .I X<0 D EN^DDIOL("Ending Date is BEFORE Beginning Date Please enter new dates","","!!,*7")

 .I X>=0 S ABSPDONE=1

 Q:ABSPQUIT

 S ABSPQUIT=$$CLNC()

 Q:ABSPQUIT=-1

 S ABSPQUIT=$$INS()

 Q:ABSPQUIT=-1

 S ABSPQUIT=$$CODE() ;IHS/OIT/SCR 092109 patch 34 - screen by selected reject code

 Q:ABSPQUIT=-1

 S ABSPQUIT=$$RTYPE()

 Q

CLNC() ; PICK WHICH OR ALL CLINIC PHARMACIES

 N DIC,X,Y

 S DIC="^ABSP(9002313.56,"

 S DIC(0)="AEMQVZ"

 S DIC("A")="Please Select a Pharmacy or leave blank for ALL:  "

 D ^DIC K DIC

 I X["^" Q -1

 I Y=-1 S ABSPPPHM="ALL"

 I Y>-1 S ABSPPPHM=$P(Y,"^",1),ABSPPHMN=$P(Y,"^",2)

 Q 1

INS() ; SELECT THE INSURER OR CHOOSE ALL INSURERS

 N DIC,X,Y

 S DIC="^ABSPEI("

 S DIC(0)="AEMNQZ"

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

 D ^DIC K DIC

 I X["^" Q -1

 I Y=-1 S ABSPINS="ALL"

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

 Q 1

CODE()  ;SELECT THE REJECTION CODE OR CHOOSE ALL CODES

 ;IHS/OIT/SCR 082109 START changes patch 34

 N DIC,X,Y

 S DIC="^ABSPRJC("

 S DIC(0)="AEMNQZ"

 S DIC("A")="Please choose a REJECTION CODE or leave blank for ALL: "

 D ^DIC K DIC

 I X["^" Q -1

 I Y=-1 S ABSPREJ="ALL"

 I Y'=-1 S ABSPREJ=$P(Y,"^",1),ABSPREJX=$P(Y,"^",2)

 Q 1

RTYPE()  ; SELECT IF YOU WANT SUMMARY, OR DETAILED

 N DIR,STARTIME,STOPTIME

 S DIR(0)="S^S:SUMMARY;D:DETAILED"

 S DIR("B")="D"

 S DIR("A")="Please select S for Summary or D for Detailed"

 D ^DIR

 I $D(DIRUT) Q -1

 S ABSPRTYP=X       ; SET REPORT TYPE

 D DEVSEL

 D ^XBCLS

 S STARTIME=$H

 D FIND

 S STOPTIME=$H

 S ^TMP("ABSPOSR5-RUNLOG",$J,STARTIME)=ABSPSTRT_"^"_$P(ABSPEND,".")_"^"_($P(STOPTIME,",",2)-$P(STARTIME,",",2)) ;IHS/OIT/CNI/RAN patch 40 081810 for benchmark

 D NEXT

 Q 1

DEVSEL ; SELECT DEVICE

 N ABSPSTOP

 S ABSPSTOP=0

 D ^%ZIS

 I POP D

 .D ^%ZIS

 I $D(DUOUT) D

  .D ZEND

  .S ABSPSTOP=1

 Q:ABSPSTOP

 I POP D

 .W "DEVICE UNAVAILABLE" G DEVSEL

 Q

FIND ; FIND REJECTIONS BY RELEASE DATE "B" CROSS REFERENCE

 N ABSPDONE,ABSPRDT,ABSPCARD,ABSPGRP,ABSPCLMI,ABSPRCNT,ABSPRNUM

 N ABSPCODE,ABSPQUIT ;IHS/OIT/SCR 082109 patch 34

 S ABSPRDT=ABSPSTRT-1

 S ABSPDONE=0

 S ABSPRMI=""

 F  S ABSPRDT=$O(^ABSPECX("RPT","B",ABSPRDT)) Q:ABSPRDT=""!ABSPDONE  D

 .I ABSPRDT>ABSPEND S ABSPDONE=1 Q

 .S ABSPTMP(ABSPRDT)=""

 .F ABSPJ=1:1 S ABSPRMI=$O(^ABSPECX("RPT","B",ABSPRDT,ABSPRMI)) Q:ABSPRMI'=+ABSPRMI  D

 ..S ABSPQUIT=0

 ..I $P(^ABSPECX("RPT",ABSPRMI,0),U,6)'=1 Q   ; NOT A REJECTED CLAIM

 ..S ABSPTRNS=$P(^ABSPECX("RPT",ABSPRMI,0),U,3),ABSPTINS=$P(^ABSPTL(ABSPTRNS,1),U,6)

 ..S ABSPPHM1=""

 ..I ABSPINS'="ALL" Q:ABSPTINS'=ABSPINS   ; NOT SELECTED INSURER

 ..I ABSPPPHM'="ALL" D

 ...I $P(^ABSPTL(ABSPTRNS,1),U,7)'=ABSPPPHM Q   ; NOT SELECTED PHARMACY

 ...S ABSPPHM1=ABSPPPHM

 ...Q

 ..I ABSPPPHM="ALL" S ABSPPHM1=$P(^ABSPTL(ABSPTRNS,1),U,7)    ; SET PHARMACY

 ..I ABSPPHM1="" Q

 ..;IHS/OIT/SCR 082109 START changes patch 34

 ..I ABSPREJ'="ALL" D  ;QUIT IF NOT SELECTED REJECT CODE

 ...I $D(^ABSPECX("RPT",ABSPRMI,"R",0)) D

 ....S ABSPREA=$P($G(^ABSPECX("RPT",ABSPRMI,"R",1,0)),U,1)

 ....S ABSPNUM=$P(ABSPREA,":",1)

 ...I ABSPREJX'=ABSPNUM S ABSPQUIT=1

 ...Q

 ..Q:ABSPQUIT

 ..;IHS/OIT/SCR 082109 END changes patch 34

 ..I $D(^ABSPECX("RPT",ABSPRMI,"R",0)) D

 ...S ABSPREA=$P(^ABSPECX("RPT",ABSPRMI,"R",1,0),U,1)

 ...S ABSPRNUM=$P(ABSPREA,":",1)

 ...S ABSPRCD="R"

 ...Q

 ..I '$D(^ABSPECX("RPT",ABSPRMI,"R",0)) D

 ...S ABSPREA=$P($G(^ABSPECX("RPT",ABSPRMI,"M",1,0)),U,1)

 ...S:ABSPREA="" ABSPREA="UKN"

 ...S ABSPRNUM="999"

 ...S ABSPRCD="M"   ; GET reason

 ...Q

 ..S ABSPCLMI=$P(^ABSPTL(ABSPTRNS,0),"^",4)

 ..S ABSPGRP=""

 ..S ABSPCARD=""

 ..I ABSPCLMI'="" D

 ...S ABSPCARD=$P($G(^ABSPC(ABSPCLMI,300)),"^",2)  ;TRANSACTION:CLAIM:Cardholder ID Number

 ...S ABSPCARD=$E(ABSPCARD,3,$L(ABSPCARD))  ;STRIP THE 2 CHARACTER QUALIFIER

 ...S ABSPGRP=$P($G(^ABSPC(ABSPCLMI,300)),"^",1)    ;TRANSACTION:CLAIM:Group Number

 ...S ABSPGRP=$E(ABSPGRP,3,$L(ABSPGRP)) ;STRIP THE 2 CHARACTER QUALIFIER

 ..;S ABSPRCNT=$P($G(ABSPREAS(ABSPRNUM)),"^",1)+1

 ..S ABSPRCNT=$P($G(ABSPREAS(ABSPRNUM,ABSPPHM1)),"^",1)+1   ;IHS/OIT/SCR 110309 patch 35

 ..;S ABSPREAS(ABSPRNUM)=ABSPRCNT_"^"_ABSPREA   ;COUNT OF REJECT REASON TYPE^REJECT REASON

 ..S ABSPREAS(ABSPRNUM,ABSPPHM1)=ABSPRCNT_"^"_ABSPREA   ;IHS/OIT/SCR 110309 patch 35

 ..S ABSPTMP(ABSPRDT,ABSPPHM1,ABSPTINS,ABSPRNUM,ABSPRMI)=ABSPREA_"^"_$P(^ABSPTL(ABSPTRNS,5),U,5)_"^"_$P(^ABSPTL(ABSPTRNS,0),U,6)_"^"_$P(^ABSPTL(ABSPTRNS,1),U,6)_"^"_ABSPCARD_"^"_ABSPGRP

 Q

NEXT ; WHAT TO DO NEXT

 N ABSPSTOP,ABSPOUT

 S (ABSPSTOP,ABSPOUT)=0

 I $O(ABSPTMP(""))="" D

 .D PRHDR

 .W !!," NO REJECTIONS FOUND FOR THE SELECTED DATE(S)"

 .D ZEND

 .S ABSPSTOP=1

 .Q

 Q:ABSPSTOP

 D SUM

 D PRNTSUM

 I ABSPOUT D ZEND  Q

 I ABSPRTYP["D" D PRNTDTL

 D ZEND

 Q

PRHDR ; PRINT HEADER

 N ABSPFEDT,ABSPFBDT

 U IO W:$D(ABSPSUM) @IOF

 S Y=ABSPSTRT

 D DD^%DT

 S ABSPFBDT=Y

 S Y=ABSPEND

 D DD^%DT

 S ABSPFEDT=Y

 W @IOF

 W !,?19,"Pharmacy Point of Sale Rejection Report"

 W !,?22,"Claims sorted by Rejection Reason"

 W !?22,"From "_ABSPFBDT_" TO "_ABSPFEDT

 W !?30,"***SUMMARY REPORT***",!

 Q

SUM ; PRINT SUMMARY PAGE

 ; TOTAL COUNTS BY REJECT CODE (1ST ON LIST)

 ; AND TOTAL AMT PER EACH THAT WAS REJECTED

 N ABSPPCNT

 S ABSPSRDT=""

 F  S ABSPSRDT=$O(ABSPTMP(ABSPSRDT)) Q:ABSPSRDT=""  D

 .S ABSPSPHM=""

 .F  S ABSPSPHM=$O(ABSPTMP(ABSPSRDT,ABSPSPHM)) Q:ABSPSPHM=""  D

 ..S ABSPSTIN=""

 ..F  S ABSPSTIN=$O(ABSPTMP(ABSPSRDT,ABSPSPHM,ABSPSTIN)) Q:ABSPSTIN=""  D

 ...S ABSPSRNM=""

 ...F  S ABSPSRNM=$O(ABSPTMP(ABSPSRDT,ABSPSPHM,ABSPSTIN,ABSPSRNM)) Q:ABSPSRNM=""  D

 ....S ABSPSTTL=0,ABSPSRMI="",ABSPSTL1=0

 ....F  S ABSPSRMI=$O(ABSPTMP(ABSPSRDT,ABSPSPHM,ABSPSTIN,ABSPSRNM,ABSPSRMI)) Q:ABSPSRMI=""  D

 .....S ABSPSREA=$P(ABSPTMP(ABSPSRDT,ABSPSPHM,ABSPSTIN,ABSPSRNM,ABSPSRMI),U,1)

 .....;S ABSPPCNT=$P(ABSPREAS(""_ABSPSRNM_""),U,1)    ; GET COUNT OF THIS REJECTION REASON

 .....S ABSPPCNT=$P(ABSPREAS(""_ABSPSRNM_"",ABSPSPHM),U,1)    ;IHS/OIT/SCR 110309 patch 35

 .....S ABSPSTTL=ABSPSTTL+$P(ABSPTMP(ABSPSRDT,ABSPSPHM,ABSPSTIN,ABSPSRNM,ABSPSRMI),U,2)

 ....S ABSPSTL1=ABSPSTTL+$P($G(ABSPSUM(ABSPSPHM,ABSPSRNM)),U,2)

 ....S ABSPSUM(ABSPSPHM,ABSPSRNM)=ABSPSREA_"^"_ABSPSTL1_"^"_ABSPSTIN_"^"_ABSPPCNT

 Q

PRNTSUM ; PRINT THE SUMMARY REPORT

 N ABSPGCNT,ABSPPCNT,ABSPSTOP

 S ABSPSTOP=0

 S ABSPPPHM=""

 S ABSPRTOT=0

 S ABSPPCNT=0

 S ABSPGTOT=0

 S ABSPGCNT=0

 S ABSPBTOT=0

 S ABSPSTOP=0

 S ABSPQUIT=0

 S ABSPOUT=0

 D PRHDR

 F  S ABSPPPHM=$O(ABSPSUM(ABSPPPHM)) Q:(ABSPPPHM="")!(ABSPSTOP)  D

 .I ABSPOUT S ABSPSTOP=1 Q

 .S ABSPPHMN=$P(^ABSP(9002313.56,ABSPPPHM,0),U,1)

 .;IHS/OIT/CNI/RAN 04272010 patch 39 - When printing to screen, use paging.

 .S ABSPOUT=$$WRITE^ABSPOSUU("!!,""PHARMACY: "",ABSPPHMN")

 .Q:ABSPOUT

 .S ABSPPRNM=""

 .S ABSPRTOT=0

 .S ABSPPCNT=0  ;IHS/OIT/SCR 110309 this is pharmacy count

 .;IHS/OIT/CNI/RAN 05042010 patch 39 - When printing to screen, use paging.

 .S ABSPOUT=$$WRITE^ABSPOSUU("!?2,""REJECTION CODE: "",?58,""  TOTALED: "",?68,""  RX COUNT: """)

 .Q:ABSPOUT

 .F  S ABSPPRNM=$O(ABSPSUM(ABSPPPHM,ABSPPRNM)) Q:(ABSPPRNM="")!(ABSPSTOP)  D

 ..I ABSPOUT S ABSPSTOP=1 Q

 ..S ABSPDRTR=$P(ABSPSUM(ABSPPPHM,ABSPPRNM),U,1)

 ..I ABSPDRTR'="" D

 ...;IHS/OIT/CNI/RAN 04272010 patch 39 - When printing to screen, use paging.

 ...S ABSPOUT=$$WRITE^ABSPOSUU("!?0,$P(ABSPSUM(ABSPPPHM,ABSPPRNM),U,1),?60,$J($P(ABSPSUM(ABSPPPHM,ABSPPRNM),U,2),7,2),?72,$P(ABSPSUM(ABSPPPHM,ABSPPRNM),U,4)")

 ...Q:ABSPOUT

 ...S ABSPRTOT=ABSPRTOT+$P(ABSPSUM(ABSPPPHM,ABSPPRNM),U,2)

 ...S ABSPPCNT=ABSPPCNT+$P(ABSPSUM(ABSPPPHM,ABSPPRNM),U,4)

 ..Q:ABSPOUT

 .Q:ABSPSTOP

 .Q:ABSPOUT

 .S ABSPGTOT=ABSPGTOT+ABSPRTOT

 .S ABSPGCNT=ABSPGCNT+ABSPPCNT

 .;IHS/OIT/CNI/RAN 04272010 patch 39 - When printing to screen, use paging

 .W:$Y<3 ! S ABSPOUT=$$WRITE^ABSPOSUU("!!,""TOTAL FOR PHARMACY: $"",ABSPRTOT")

 .Q:ABSPOUT

 .W:$Y<3 ! S ABSPOUT=$$WRITE^ABSPOSUU("!,""# RX REJECTED FOR PHARMACY: "",ABSPPCNT")

 .Q:ABSPOUT

 Q:ABSPSTOP

 Q:ABSPOUT

 ;IHS/OIT/CNI/RAN 04272010 patch 39 - When printing to screen, use paging

 W:$Y<3 ! S ABSPOUT=$$WRITE^ABSPOSUU("!!,""GRAND TOTAL: $"",ABSPGTOT")

 Q:ABSPOUT

 W:$Y<3 ! S ABSPOUT=$$WRITE^ABSPOSUU("!,""# RX REJECTED: "",ABSPGCNT")

 ;W:$Y<3 ! W !!,"P - Preventable, N - Non-recoverable, B - Both"

 Q

PRNTDHD ; PRINT DETAIL HEADER

 I ABSPRTYP'["D" D ZEND Q

 ;IHS/OIT/CNI/RAN 04272010 patch 39 - When printing to screen, use paging

 S ABSPOUT=$$WRITE^ABSPOSUU("!!,?21,""********** Detailed Report **********"",!")

 Q:ABSPOUT

 S ABSPOUT=$$WRITE^ABSPOSUU("!,""CHT #"",?14,""NAME"",?32,""RX #/FILL #"",?52,""INSURER"",?69,""AMT BILLED""")

 Q:ABSPOUT

 ;IHS/OIT/CNI/RAN 04282010 patch 39 - Add NDC # and Drug name

 S ABSPOUT=$$WRITE^ABSPOSUU("!,?3,""CARD HOLDER ID #"",?27,""GROUP #"",?40,""NDC #"",?60,""DRUG NAME""")

 Q

PRNTDTL  ; PRINT DETAILED REPORT

 N ABSPCARD,ABSPFRDT,ABSPGRP,ABSPSTOP,ABSPNDC,ABSPDRNM,ABSPQUIT,ABSPOUT

 S ABSPPRDT=""

 S ABSPPPHM=""

 S ABSPPRNM=""

 ;IHS/OIT/CNI/RAN 04282010 patch 39 - Add NDC # and Drug name on next two lines and New line above

 S ABSPNDC=""

 S ABSPDRNM=""

 S ABSPRTOT=0

 S ABSPGTOT=0

 S ABSPRDTL=0

 S ABSPSTOP=0

 S ABSPQUIT=0

 S ABSPOUT=0

 F  S ABSPPRDT=$O(ABSPTMP(ABSPPRDT)) Q:(ABSPPRDT="")!(ABSPQUIT)!(ABSPOUT)  D

 .S ABSPPPHM=""

 .S Y=ABSPPRDT

 .D DD^%DT

 .S ABSPFRDT=Y   ; FORMATTED RELEASE DATE

 .S ABSPRDTL=0

 .F  S ABSPPPHM=$O(ABSPTMP(ABSPPRDT,ABSPPPHM)) Q:(ABSPPPHM="")!(ABSPOUT)  D

 ..S ABSPPINS=""

 ..S ABSPPHMN=$P(^ABSP(9002313.56,ABSPPPHM,0),U,1)

 ..D PRNTDHD

 ..Q:ABSPOUT

 ..;IHS/OIT/CNI/RAN 04272010 patch 39 - When printing to screen, use paging

 ..S ABSPOUT=$$WRITE^ABSPOSUU("!!,?5,""PHARMACY: "",ABSPPHMN,""   RELEASED DATE: "",ABSPFRDT")

 ..Q:ABSPOUT

 ..S ABSPBTOT=0

 ..F  S ABSPPINS=$O(ABSPTMP(ABSPPRDT,ABSPPPHM,ABSPPINS)) Q:(ABSPPINS="")!(ABSPOUT)  D

 ...S ABSPPRNM=""

 ...F  S ABSPPRNM=$O(ABSPTMP(ABSPPRDT,ABSPPPHM,ABSPPINS,ABSPPRNM)) Q:(ABSPPRNM="")!(ABSPOUT)  D

 ....S ABSPPRMI=""

 ....S ABSPRJCD=$P(ABSPREAS(""_ABSPPRNM_"",ABSPPPHM),U,2) ;IHS/OIT/SCR 111309 patch 35

 ....;IHS/OIT/CNI/RAN 04272010 patch 39 - When printing to screen, use paging

 ....S ABSPOUT=$$WRITE^ABSPOSUU("!!,?15,""REJECTION CODE: "",$E(ABSPRJCD,1,48)")

 ....Q:ABSPOUT

 ....F  S ABSPPRMI=$O(ABSPTMP(ABSPPRDT,ABSPPPHM,ABSPPINS,ABSPPRNM,ABSPPRMI)) Q:(ABSPPRMI="")!(ABSPOUT)  D

 .....S (ABSPPCHT,ABSPPDIV,ABSPOPS)=""

 .....S ABSPPAT=$P(ABSPTMP(ABSPPRDT,ABSPPPHM,ABSPPINS,ABSPPRNM,ABSPPRMI),U,3)

 .....S ABSPCARD=$P(ABSPTMP(ABSPPRDT,ABSPPPHM,ABSPPINS,ABSPPRNM,ABSPPRMI),U,5)

 .....S ABSPGRP=$P(ABSPTMP(ABSPPRDT,ABSPPPHM,ABSPPINS,ABSPPRNM,ABSPPRMI),U,6)

 .....S ABSPPATN=$E($P(^DPT(ABSPPAT,0),U,1),1,20)

 .....S ABSPOPS=$P($G(^ABSP(9002313.56,ABSPPPHM,"OPSITE",1,0)),U,1)  ;OUTPATIENT SITE MIGHT NOT BE DEFINED

 .....S:ABSPOPS'="" ABSPPDIV=$P($G(^PS(59,ABSPOPS,0)),U,6)  ;NO OUTPATIENT SITE MEANS NO DIVISION

 .....S:ABSPPDIV'="" ABSPPCHT=$P($G(^AUPNPAT(ABSPPAT,41,ABSPPDIV,0)),U,2)  ;NO DIVISION MEANS NO CHART #

 .....S ABSPPRX=$P(^ABSPECX("RPT",ABSPPRMI,0),U,4)

 .....S ABSPPRXR=$P($G(^ABSPECX("RPT",ABSPPRMI,0)),U,5)  ; SET INTERNAL RX # AND REFILL #

 .....S ABSPPTP=$P(ABSPTMP(ABSPPRDT,ABSPPPHM,ABSPPINS,ABSPPRNM,ABSPPRMI),U,2)  ; PRICE

 .....S ABSPINSN=$E($P($G(^AUTNINS(ABSPPINS,0)),U,1),1,22)   ; INSURER NAME

 .....;IHS/OIT/CNI/RAN 04282010 patch 39 - Add NDC # and Drug name BEGIN

 .....N ABSPTRNS,ABSPCLMI

 .....S ABSPTRNS=$P($G(^ABSPECX("RPT",ABSPPRMI,0)),"^",3)

 .....S ABSPCLMI=$P($G(^ABSPTL(ABSPTRNS,0)),"^",4)

 .....S NDCDRG=$$GTNDCDRG^ABSPOSUU(ABSPCLMI,ABSPPRX)

 .....S ABSPNDC=$P(NDCDRG,"^",1)

 .....S ABSPDRNM=$P(NDCDRG,"^",2)

 .....;IHS/OIT/CNI/RAN 04272010 patch 39 - When printing to screen, use paging

 .....S ABSPOUT=$$WRITE^ABSPOSUU("!,ABSPPCHT,?9,ABSPPATN,?31,ABSPPRX_""/""_ABSPPRXR,?45,ABSPINSN,?70,""$""_$J(ABSPPTP,6,2)")

 .....Q:ABSPOUT

 .....;IHS/OIT/CNI/RAN 04282010 patch 39 - Add NDC # and Drug name

 .....S ABSPOUT=$$WRITE^ABSPOSUU("!,?3,ABSPCARD,?27,ABSPGRP,?40,ABSPNDC,?60,ABSPDRNM")

 .....Q:ABSPOUT

 .....;IHS/OIT/CNI/RAN 04272010 patch 39 - When printing to screen, use paging.

 .....S ABSBPRTT=ABSPRTOT+ABSPPTP

 .....S ABSPBTOT=ABSPPTP+ABSPBTOT

 .....S ABSPRDTL=ABSPRDTL+ABSPPTP

 ...Q:ABSPOUT

 ..Q:ABSPOUT

 ..;IHS/OIT/CNI/RAN 04272010 patch 39 - When printing to screen, use paging

 ..S ABSPOUT=$$WRITE^ABSPOSUU("!!,""TOTAL FOR "",ABSPPHMN,"": $"",$J(ABSPBTOT,6,2),!")

 .Q:ABSPOUT

 .;IHS/OIT/CNI/RAN 04272010 patch 39 - When printing to screen, use paging

 .S ABSPOUT=$$WRITE^ABSPOSUU("!!,""TOTAL FOR RELEASED DATE "",ABSPFRDT,"": $"",$J(ABSPRDTL,6,2)")

 .Q:ABSPOUT

 .S ABSPGTOT=ABSPGTOT+ABSPRDTL

 Q:ABSPSTOP

 Q:ABSPOUT

 ;I $D(ABSPRTYP) W !!,"TOTAL AMOUNT REJECTED: ",ABSBPRTT,!!,"P - Preventable, N - Non-recoverable, B - Both"

 ;IHS/OIT/CNI/RAN 04272010 patch 39 - When printing to screen, use paging

 I $D(ABSPRTYP) S ABSPOUT=$$WRITE^ABSPOSUU("!!,""TOTAL AMOUNT REJECTED: $"",$J(ABSPGTOT,6,2),!!")

 Q

ZEND ; END AND KILL VARIABLES

 D ^%ZISC

 K ABSPTMP,ABSPSUM,ABSBPRTT,ABSPBTOT,ABSPGTOT,ABSPRTOT,ABSPINS,ABSPPTP,ABSPPAT,ABSPPCHT,ABSPINSN,ABSPPRX,ABSPPRMI,ABSPPRXR,ABSPPDIV,ABSPOPS,ABSPPATN,ABSPPPHM,ABSPPRDT

 K ABSPREAS,ABSPRMI,ABSPSRDT,ABSPSTTL,ABSPSRMI,ABSPSPHM,ABSPSRNM,RNUM,ABSPSTIN,ABSPFBDT,ABSPFEDT,ABSPBDT,ABSPEDT,ABSPTINS,ABSPTRNS,ABSPJ,ABSPRTYP,ABSPDRT,ABSPDRTR,ABSPRJCD

 K ABSPPHM1,ABSPPHMN,ABSPPINS,ABSPPRNM,ABSPRCD,ABSPRDTL,ABSPREA,ABSPSREA,ABSPSTL1,ABSPSTRT

 Q

START  ;

 N X,Y,ABSPJ,ABSPRJC,ABSPPAT,ABSPPIEN

 I $D(ZTQPARAM) D

 .I $P(ZTQPARAM,";",1)["T-1" S ABSPSTRT=DT-1

 .I $P(ZTQPARAM,";",2)["T-1" S ABSPEND=DT-1

 .S ABSPINS="ALL"

 .S ABSPPPHM="ALL"

 .S ABSPRTYP="D"

 .D FIND

 .D ZEND

 Q

BDT()  ; ENTER BEGINING DATE

 N ABSPBDT,DIR,X1,X

 W !

 K DIR

 S DIR(0)="DEX"

 S DIR("A")="Enter Beginning Prescription Release Date"

 D ^DIR

 I $D(DIRUT) Q -1

 S ABSPBDT=+Y

 S X1=ABSPBDT D C^%DTC

 Q X

EDT()  ; ENTER END DATE

 N ABSPEDT,DIR,X1,X

 W !

 K DIR

 S DIR(0)="DEX"

 S DIR("A")="Enter Ending Prescription Release Date"

 D ^DIR

 I $D(DIRUT) Q -1

 S ABSPEDT=+Y

 S X1=ABSPEDT D C^%DTC

 Q X

ABSPOSR5  ;IHS/OIT/SCR - REJECTION REPORT BY REJECTION REASON

 +1       ;;1.0;PHARMACY POINT OF SALE;**29,30,34,35,39,40**;JUN 21, 2001;Build 38

 +2       ; DISPLAYS POS CLAIMS BY REJECT CODE

 +3       ; PATCH 40 NOTES: This routine was removed from POS MENUs and replaced with routine ABSPOSRY which does not use

 +4       ;  ABSP REPORT MASTER file or the ^ABSPT("NON-FILEMAN" cross-reference. It is staying with the build for comparison

 +5       ;  

UPD       ; UPDATE THE REPORT MASTER FILE IN ABSP

 +1        NEW ABSPQUIT,ABSPDONE,ABSPSTRT,ABSPEND,ABSPLCNT

 +2       ;D AUTO^ABSPOSM1()    ;IHS/OIT/CNI/SCR patch 40 - can't run this from the prompt

 +3        IF $DATA(ZTQPARAM)

               DO START

 +4        SET ABSPDONE=0

 +5        SET ABSPQUIT=0

 +6        FOR 

               IF ABSPDONE=1

                   QUIT 

               Begin DoDot:1

 +7                SET ABSPSTRT=$$BDT()

 +8                IF ABSPSTRT=-1

                       Begin DoDot:2

 +9                        SET ABSPQUIT=1

 +10                       SET ABSPDONE=1

                       End DoDot:2

 +11               IF ABSPQUIT

                       QUIT 

 +12               SET ABSPEND=$$EDT()

 +13               IF ABSPEND=-1

                       Begin DoDot:2

 +14                       SET ABSPQUIT=1

 +15                       SET ABSPDONE=1

                       End DoDot:2

 +16               IF ABSPQUIT

                       QUIT 

 +17               IF ABSPSTRT<0

                       SET ABSPDONE=1

                       QUIT 

 +18               IF ABSPEND<0

                       SET ABSPDONE=1

                       QUIT 

 +19               SET X2=ABSPSTRT

                   SET X1=ABSPEND

                   DO ^%DTC

 +20               IF X<0

                       DO EN^DDIOL("Ending Date is BEFORE Beginning Date Please enter new dates","","!!,*7")

 +21               IF X>=0

                       SET ABSPDONE=1

               End DoDot:1

 +22       IF ABSPQUIT

               QUIT 

 +23       SET ABSPQUIT=$$CLNC()

 +24       IF ABSPQUIT=-1

               QUIT 

 +25       SET ABSPQUIT=$$INS()

 +26       IF ABSPQUIT=-1

               QUIT 

 +27      ;IHS/OIT/SCR 092109 patch 34 - screen by selected reject code

           SET ABSPQUIT=$$CODE()

 +28       IF ABSPQUIT=-1

               QUIT 

 +29       SET ABSPQUIT=$$RTYPE()

 +30       QUIT 

CLNC()    ; PICK WHICH OR ALL CLINIC PHARMACIES

 +1        NEW DIC,X,Y

 +2        SET DIC="^ABSP(9002313.56,"

 +3        SET DIC(0)="AEMQVZ"

 +4        SET DIC("A")="Please Select a Pharmacy or leave blank for ALL:  "

 +5        DO ^DIC

           KILL DIC

 +6        IF X["^"

               QUIT -1

 +7        IF Y=-1

               SET ABSPPPHM="ALL"

 +8        IF Y>-1

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

               SET ABSPPHMN=$PIECE(Y,"^",2)

 +9        QUIT 1

INS()     ; SELECT THE INSURER OR CHOOSE ALL INSURERS

 +1        NEW DIC,X,Y

 +2        SET DIC="^ABSPEI("

 +3        SET DIC(0)="AEMNQZ"

 +4        SET DIC("A")="Please choose an insurer or leave blank for ALL POS electronic insurers: "

 +5        DO ^DIC

           KILL DIC

 +6        IF X["^"

               QUIT -1

 +7        IF Y=-1

               SET ABSPINS="ALL"

 +8        IF Y'=-1

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

               SET ABSPINSN=$PIECE(Y,"^",2)

 +9        QUIT 1

CODE()    ;SELECT THE REJECTION CODE OR CHOOSE ALL CODES

 +1       ;IHS/OIT/SCR 082109 START changes patch 34

 +2        NEW DIC,X,Y

 +3        SET DIC="^ABSPRJC("

 +4        SET DIC(0)="AEMNQZ"

 +5        SET DIC("A")="Please choose a REJECTION CODE or leave blank for ALL: "

 +6        DO ^DIC

           KILL DIC

 +7        IF X["^"

               QUIT -1

 +8        IF Y=-1

               SET ABSPREJ="ALL"

 +9        IF Y'=-1

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

               SET ABSPREJX=$PIECE(Y,"^",2)

 +10       QUIT 1

RTYPE()   ; SELECT IF YOU WANT SUMMARY, OR DETAILED

 +1        NEW DIR,STARTIME,STOPTIME

 +2        SET DIR(0)="S^S:SUMMARY;D:DETAILED"

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

 +4        SET DIR("A")="Please select S for Summary or D for Detailed"

 +5        DO ^DIR

 +6        IF $DATA(DIRUT)

               QUIT -1

 +7       ; SET REPORT TYPE

           SET ABSPRTYP=X

 +8        DO DEVSEL

 +9        DO ^XBCLS

 +10       SET STARTIME=$HOROLOG

 +11       DO FIND

 +12       SET STOPTIME=$HOROLOG

 +13      ;IHS/OIT/CNI/RAN patch 40 081810 for benchmark

           SET ^TMP("ABSPOSR5-RUNLOG",$JOB,STARTIME)=ABSPSTRT_"^"_$PIECE(ABSPEND,".")_"^"_($PIECE(STOPTIME,",",2)-$PIECE(STARTIME,",",2))

 +14       DO NEXT

 +15       QUIT 1

DEVSEL    ; SELECT DEVICE

 +1        NEW ABSPSTOP

 +2        SET ABSPSTOP=0

 +3        DO ^%ZIS

 +4        IF POP

               Begin DoDot:1

 +5                DO ^%ZIS

               End DoDot:1

 +6        IF $DATA(DUOUT)

               Begin DoDot:1

 +7                DO ZEND

 +8                SET ABSPSTOP=1

               End DoDot:1

 +9        IF ABSPSTOP

               QUIT 

 +10       IF POP

               Begin DoDot:1

 +11               WRITE "DEVICE UNAVAILABLE"

                   GOTO DEVSEL

               End DoDot:1

 +12       QUIT 

FIND      ; FIND REJECTIONS BY RELEASE DATE "B" CROSS REFERENCE

 +1        NEW ABSPDONE,ABSPRDT,ABSPCARD,ABSPGRP,ABSPCLMI,ABSPRCNT,ABSPRNUM

 +2       ;IHS/OIT/SCR 082109 patch 34

           NEW ABSPCODE,ABSPQUIT

 +3        SET ABSPRDT=ABSPSTRT-1

 +4        SET ABSPDONE=0

 +5        SET ABSPRMI=""

 +6        FOR 

               SET ABSPRDT=$ORDER(^ABSPECX("RPT","B",ABSPRDT))

               IF ABSPRDT=""!ABSPDONE

                   QUIT 

               Begin DoDot:1

 +7                IF ABSPRDT>ABSPEND

                       SET ABSPDONE=1

                       QUIT 

 +8                SET ABSPTMP(ABSPRDT)=""

 +9                FOR ABSPJ=1:1

                       SET ABSPRMI=$ORDER(^ABSPECX("RPT","B",ABSPRDT,ABSPRMI))

                       IF ABSPRMI'=+ABSPRMI

                           QUIT 

                       Begin DoDot:2

 +10                       SET ABSPQUIT=0

 +11      ; NOT A REJECTED CLAIM

                           IF $PIECE(^ABSPECX("RPT",ABSPRMI,0),U,6)'=1

                               QUIT 

 +12                       SET ABSPTRNS=$PIECE(^ABSPECX("RPT",ABSPRMI,0),U,3)

                           SET ABSPTINS=$PIECE(^ABSPTL(ABSPTRNS,1),U,6)

 +13                       SET ABSPPHM1=""

 +14      ; NOT SELECTED INSURER

                           IF ABSPINS'="ALL"

                               IF ABSPTINS'=ABSPINS

                                   QUIT 

 +15                       IF ABSPPPHM'="ALL"

                               Begin DoDot:3

 +16      ; NOT SELECTED PHARMACY

                                   IF $PIECE(^ABSPTL(ABSPTRNS,1),U,7)'=ABSPPPHM

                                       QUIT 

 +17                               SET ABSPPHM1=ABSPPPHM

 +18                               QUIT 

                               End DoDot:3

 +19      ; SET PHARMACY

                           IF ABSPPPHM="ALL"

                               SET ABSPPHM1=$PIECE(^ABSPTL(ABSPTRNS,1),U,7)

 +20                       IF ABSPPHM1=""

                               QUIT 

 +21      ;IHS/OIT/SCR 082109 START changes patch 34

 +22      ;QUIT IF NOT SELECTED REJECT CODE

                           IF ABSPREJ'="ALL"

                               Begin DoDot:3

 +23                               IF $DATA(^ABSPECX("RPT",ABSPRMI,"R",0))

                                       Begin DoDot:4

 +24                                       SET ABSPREA=$PIECE($GET(^ABSPECX("RPT",ABSPRMI,"R",1,0)),U,1)

 +25                                       SET ABSPNUM=$PIECE(ABSPREA,":",1)

                                       End DoDot:4

 +26                               IF ABSPREJX'=ABSPNUM

                                       SET ABSPQUIT=1

 +27                               QUIT 

                               End DoDot:3

 +28                       IF ABSPQUIT

                               QUIT 

 +29      ;IHS/OIT/SCR 082109 END changes patch 34

 +30                       IF $DATA(^ABSPECX("RPT",ABSPRMI,"R",0))

                               Begin DoDot:3

 +31                               SET ABSPREA=$PIECE(^ABSPECX("RPT",ABSPRMI,"R",1,0),U,1)

 +32                               SET ABSPRNUM=$PIECE(ABSPREA,":",1)

 +33                               SET ABSPRCD="R"

 +34                               QUIT 

                               End DoDot:3

 +35                       IF '$DATA(^ABSPECX("RPT",ABSPRMI,"R",0))

                               Begin DoDot:3

 +36                               SET ABSPREA=$PIECE($GET(^ABSPECX("RPT",ABSPRMI,"M",1,0)),U,1)

 +37                               IF ABSPREA=""

                                       SET ABSPREA="UKN"

 +38                               SET ABSPRNUM="999"

 +39      ; GET reason

                                   SET ABSPRCD="M"

 +40                               QUIT 

                               End DoDot:3

 +41                       SET ABSPCLMI=$PIECE(^ABSPTL(ABSPTRNS,0),"^",4)

 +42                       SET ABSPGRP=""

 +43                       SET ABSPCARD=""

 +44                       IF ABSPCLMI'=""

                               Begin DoDot:3

 +45      ;TRANSACTION:CLAIM:Cardholder ID Number

                                   SET ABSPCARD=$PIECE($GET(^ABSPC(ABSPCLMI,300)),"^",2)

 +46      ;STRIP THE 2 CHARACTER QUALIFIER

                                   SET ABSPCARD=$EXTRACT(ABSPCARD,3,$LENGTH(ABSPCARD))

 +47      ;TRANSACTION:CLAIM:Group Number

                                   SET ABSPGRP=$PIECE($GET(^ABSPC(ABSPCLMI,300)),"^",1)

 +48      ;STRIP THE 2 CHARACTER QUALIFIER

                                   SET ABSPGRP=$EXTRACT(ABSPGRP,3,$LENGTH(ABSPGRP))

                               End DoDot:3

 +49      ;S ABSPRCNT=$P($G(ABSPREAS(ABSPRNUM)),"^",1)+1

 +50      ;IHS/OIT/SCR 110309 patch 35

                           SET ABSPRCNT=$PIECE($GET(ABSPREAS(ABSPRNUM,ABSPPHM1)),"^",1)+1

 +51      ;S ABSPREAS(ABSPRNUM)=ABSPRCNT_"^"_ABSPREA   ;COUNT OF REJECT REASON TYPE^REJECT REASON

 +52      ;IHS/OIT/SCR 110309 patch 35

                           SET ABSPREAS(ABSPRNUM,ABSPPHM1)=ABSPRCNT_"^"_ABSPREA

 +53                       SET ABSPTMP(ABSPRDT,ABSPPHM1,ABSPTINS,ABSPRNUM,ABSPRMI)=ABSPREA_"^"_$PIECE(^ABSPTL(ABSPTRNS,5),U,5)_"^"_$PIECE(^ABSPTL(ABSPTRNS,0),U,6)_"^"_$PIECE(^ABSPTL(ABSPTRNS,1),U,6)_"^"_ABSPCARD_"^"_ABSPGRP

                       End DoDot:2

               End DoDot:1

 +54       QUIT 

NEXT      ; WHAT TO DO NEXT

 +1        NEW ABSPSTOP,ABSPOUT

 +2        SET (ABSPSTOP,ABSPOUT)=0

 +3        IF $ORDER(ABSPTMP(""))=""

               Begin DoDot:1

 +4                DO PRHDR

 +5                WRITE !!," NO REJECTIONS FOUND FOR THE SELECTED DATE(S)"

 +6                DO ZEND

 +7                SET ABSPSTOP=1

 +8                QUIT 

               End DoDot:1

 +9        IF ABSPSTOP

               QUIT 

 +10       DO SUM

 +11       DO PRNTSUM

 +12       IF ABSPOUT

               DO ZEND

               QUIT 

 +13       IF ABSPRTYP["D"

               DO PRNTDTL

 +14       DO ZEND

 +15       QUIT 

PRHDR     ; PRINT HEADER

 +1        NEW ABSPFEDT,ABSPFBDT

 +2        USE IO

           IF $DATA(ABSPSUM)

               WRITE @IOF

 +3        SET Y=ABSPSTRT

 +4        DO DD^%DT

 +5        SET ABSPFBDT=Y

 +6        SET Y=ABSPEND

 +7        DO DD^%DT

 +8        SET ABSPFEDT=Y

 +9        WRITE @IOF

 +10       WRITE !,?19,"Pharmacy Point of Sale Rejection Report"

 +11       WRITE !,?22,"Claims sorted by Rejection Reason"

 +12       WRITE !?22,"From "_ABSPFBDT_" TO "_ABSPFEDT

 +13       WRITE !?30,"***SUMMARY REPORT***",!

 +14       QUIT 

SUM       ; PRINT SUMMARY PAGE

 +1       ; TOTAL COUNTS BY REJECT CODE (1ST ON LIST)

 +2       ; AND TOTAL AMT PER EACH THAT WAS REJECTED

 +3        NEW ABSPPCNT

 +4        SET ABSPSRDT=""

 +5        FOR 

               SET ABSPSRDT=$ORDER(ABSPTMP(ABSPSRDT))

               IF ABSPSRDT=""

                   QUIT 

               Begin DoDot:1

 +6                SET ABSPSPHM=""

 +7                FOR 

                       SET ABSPSPHM=$ORDER(ABSPTMP(ABSPSRDT,ABSPSPHM))

                       IF ABSPSPHM=""

                           QUIT 

                       Begin DoDot:2

 +8                        SET ABSPSTIN=""

 +9                        FOR 

                               SET ABSPSTIN=$ORDER(ABSPTMP(ABSPSRDT,ABSPSPHM,ABSPSTIN))

                               IF ABSPSTIN=""

                                   QUIT 

                               Begin DoDot:3

 +10                               SET ABSPSRNM=""

 +11                               FOR 

                                       SET ABSPSRNM=$ORDER(ABSPTMP(ABSPSRDT,ABSPSPHM,ABSPSTIN,ABSPSRNM))

                                       IF ABSPSRNM=""

                                           QUIT 

                                       Begin DoDot:4

 +12                                       SET ABSPSTTL=0

                                           SET ABSPSRMI=""

                                           SET ABSPSTL1=0

 +13                                       FOR 

                                               SET ABSPSRMI=$ORDER(ABSPTMP(ABSPSRDT,ABSPSPHM,ABSPSTIN,ABSPSRNM,ABSPSRMI))

                                               IF ABSPSRMI=""

                                                   QUIT 

                                               Begin DoDot:5