ABSPOSRT.m

ABSPOSRT  ;IHS/OIT/CNI/RAN - Transaction History Report

 ;;1.0;PHARMACY POINT OF SALE;**40,47**;JUN 21, 2001;Build 38

 ; ABSP TRANSACTION HISTORY REPORT

 ; DISPLAYS ALL TRANSACTIONS FOR A GIVEN PRESCRIPTION

EN ; 

 N ABSPQUIT,ABSPDONE,ABSPSTRT,ABSPEND,ABSPLCNT,ABSPREJ,ABSPRJ,U,ABSPTMP,ABSPTMPC,ABSPCLM,ABSPUSER,ABSPPPHM,X

 S U="^"

 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

 .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

 Q:ABSPQUIT

 S ABSPQUIT=$$CLNC^ABSPOSUU()

 Q:ABSPQUIT=-1

 S ABSPQUIT=$$USER^ABSPOSUU()

 D DEVSEL

 Q:ABSPQUIT=-1

 D ^XBCLS

 D FIND

 D NEXT

 Q

DEVSEL ; SELECT DEVICE

 N ABSPSTOP

 S ABSPSTOP=0

 D ^%ZIS

 I POP D

 .D ^%ZIS

 .Q

 I $D(DUOUT) D

  .D ZEND

  .S ABSPSTOP=1

  .Q

 Q:ABSPSTOP

 I POP D

 .W "DEVICE UNAVAILABLE" G DEVSEL

 Q

FIND ; FIND TRANSACTIONS BY TRANSACTION DATE USING "AH" CROSS REFERENCE

 N ABSPRDT,ABSPDONE,ABSPDONE,ABSPTRN,ABSPTPTL,ABSPRESC,ABSPRESP

 S ABSPRDT=ABSPSTRT

 S ABSPEND=ABSPEND_".99999999"

 S ABSPDONE=0

 ;GO THROUGH INDEX BY TRANSACTION DATE

 F  S ABSPRDT=$O(^ABSPTL("AH",ABSPRDT)) Q:(ABSPRDT="")!(ABSPDONE)!(+ABSPRDT=0)  D

 .I ABSPRDT>ABSPEND S ABSPDONE=1 Q

 .S ABSPTRN=""

 .F  S ABSPTRN=$O(^ABSPTL("AH",ABSPRDT,ABSPTRN)) Q:(ABSPTRN="")!(ABSPDONE)  D

 ..S ABSPRESC=$P(^ABSPTL(ABSPTRN,0),U)

 ..D GETINFO($P(ABSPRDT,"."),ABSPTRN,ABSPRESC)

 Q

GETINFO(ABSPRDT,ABSPTRN,ABSPRESC) ;GET ALL INFO FOR THIS PARTICULAR TRANSACTION

 N ABSPTPTL,ABSPPRI,DO,ABSPTYPI,ABSPTTYP,ABSPRNUM,ABSPREA,ABSPBAMT,ABSPPHM1,ABSPPAID,ABSPUSR1,ABSPCLMI,ABSPORIG,ABSP9PTL,ABSP1PTL,ABSPTDT,ABSPTL

 M ABSPTL(ABSPTRN)=^ABSPTL(ABSPTRN)

 S ABSPTPTL=ABSPTL(ABSPTRN,0)

 S ABSP1PTL=ABSPTL(ABSPTRN,1)

 S ABSP9PTL=$G(ABSPTL(ABSPTRN,9))

 S ABSPPRI=$P(ABSPTPTL,U,5)

 S ABSPCLMI=$P(ABSPTPTL,U,4)

 I ABSPPRI="" D              ;NON ELECTRONIC...THIS IS A PAPER CLAIM

 . S ABSPTTYP="PAPER"

 . S (ABSPRNUM,ABSPREA)=""

 . S ABSPPAID=0

 . I '$D(ABSPTL(ABSPTRN,5)) S ABSPTTYP="REVERSED",ABSPBAMT=0

 S ABSPPHM1=$P(ABSP1PTL,U,7)    ; SET PHARMACY

 I (ABSPPPHM'="ALL")&&(ABSPPHM1'=ABSPPPHM) Q   ; NOT SELECTED PHARMACY

 I ABSPPHM1="" S ABSPPHM1=ABSPPPHM

 S ABSPUSR1=$P(ABSPTPTL,U,17)

 I (ABSPUSER'="ALL"),(ABSPUSR1'=ABSPUSER) Q   ; NOT SELECTED USER

 I ABSPUSR1="" S ABSPUSR1=ABSPUSER

 I $D(ABSPTL(ABSPTRN,5)) S ABSPBAMT=$P(ABSPTL(ABSPTRN,5),U,5)  ;Billed amount

 ELSE  S ABSPBAMT=0

 I ABSPPRI'="" D  ;SKIP ALL THIS IF WE HAVE PAPER CLAIM

 .S DO=$P(ABSPTPTL,U,9)

 .I '$D(^ABSPR(ABSPPRI,1000,DO)) S DO=$$GETDO^ABSPOSUU(ABSPPRI,$P(ABSPRESC,"."))

 .Q:DO=""

 .S ABSPTYPI=$P(^ABSPR(ABSPPRI,1000,DO,500),U)

 .S ABSPTTYP=$S(ABSPTYPI="P":"PAYABLE",ABSPTYPI="R":"REJECTED",ABSPTYPI="D":"DUPLICATE",1:"PAPER")

 .S (ABSPRNUM,ABSPREA)=""

 .I ABSPTYPI="R" D

 .. I '$D(^ABSPR(ABSPPRI,1000,DO,511)) S (ABSPRNUM,ABSPREA)="UKN"   ;Added to skip junk data in PMAA test area

 .. E  D

 ... S ABSPRNUM=$P(^ABSPR(ABSPPRI,1000,DO,511,1,0),U)

 ... I '$D(^ABSPF(9002313.93,"B",ABSPRNUM)) S ABSPREA="Reject Code description not entered,See NCPDP Rejects" Q  ;IHS/OIT/RCS PATCH 47

 ... S ABSPREA=$P(^ABSPF(9002313.93,$O(^ABSPF(9002313.93,"B",ABSPRNUM,"")),0),U,2)

 .. S ABSPPAID=0

 .I ABSPTYPI="P" D

 ..S ABSPPAID=$$DFF2EXT^ABSPECFM($P(^ABSPR(ABSPPRI,1000,DO,500),U,9)),ABSPRESP(ABSPPRI)=""

 ..S (ABSPRNUM,ABSPREA)=""

 .I ABSPTYPI="D" S ABSPPAID=0

 I ABSP9PTL'="" D

 . S ABSPTDT=$P(ABSPTPTL,U,8)

 . I $P(ABSP9PTL,U)=1 S ABSPTTYP="CLOSED",ABSPRNUM="",ABSPREA="",ABSPBAMT=0,ABSPPAID=0

 . I ($P(ABSP9PTL,U)=0)&($P(ABSP9PTL,U,4)=ABSPTDT) S ABSPTTYP="REOPENED"

 Q:$G(ABSPTTYP)=""

 I '$D(ABSPTMPC(ABSPRESC)) S ABSPTMPC(ABSPRESC)=1

 E  S ABSPTMPC(ABSPRESC)=ABSPTMPC(ABSPRESC)+1

 S ^TMP("ABSPOSRT",$J,ABSPRDT,ABSPPHM1,ABSPUSR1,ABSPRESC,ABSPTRN)=ABSPTMPC(ABSPRESC)_U_ABSPTTYP_U_ABSPRNUM_U_ABSPREA_U_ABSPBAMT_U_ABSPPAID_U_ABSPPRI

 S ABSPCLM(ABSPRESC)=ABSPCLMI

 Q

NEXT ; WHAT TO DO NEXT

 N ABSPSTOP,ABSPOUT

 S (ABSPSTOP,ABSPOUT)=0

 D PRHDR

 I $O(^TMP("ABSPOSRT",$J,""))="" D

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

 .D ZEND

 .S ABSPSTOP=1

 .Q

 Q:ABSPSTOP

 I ABSPOUT D ZEND  Q

 D PRNTDTL

 D ZEND

 Q

PRHDR ; PRINT HEADER

 N ABSPFEDT,ABSPFBDT,Y

 U IO W:$D(ABSPSUM) @IOF

 S Y=ABSPSTRT

 D DD^%DT

 S ABSPFBDT=Y

 S Y=$P(ABSPEND,".")

 D DD^%DT

 S ABSPFEDT=Y

 W @IOF

 W !,?16,"Pharmacy Point of Sale Transaction History Report"

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

 W !?18,"Pharmacy: "_ABSPPPHM

 W !?22,"User: "_ABSPUSER

 Q

PRNTDHD ; PRINT HEADER

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

 S ABSPOUT=$$WRITE^ABSPOSUU("!,""SUBMISSION"",?14,""STATUS"",?25,""REJ"",?30,""REJ REASON"",?58,""BILLED AMT"",?70,""PAID AMT""")

 Q:ABSPOUT

 Q

PRNTDTL  ; PRINT DETAIL

 N ABSPTRDT,ABSPOUT,Y,ABSPFRDT,ABSPPPHM,ABSPPHMN,ABSPRESC,ABSPTRN,STRING,ABSPSUB,ABSPTYP,ABSPRJCD,ABSPREA,ABSPBAMT,ABSPPAID,ABSPUSRN

 N ABSPRXGT,ABSPSBGT,ABSPAYGT,ABSPDATE,ABSPUSR,ABSPHARM,ABSPRESP,ABSPREST,ABSPAID1,ABSPUSER,ABSPCLMI,ABSPPRI,ABSPPRX,ABSPPRXR,ABSPOTH

 S (ABSPRXGT,ABSPSBGT,ABSPAYGT)=0

 S (ABSPTRDT,ABSPOUT)=""

 F  S ABSPTRDT=$O(^TMP("ABSPOSRT",$J,ABSPTRDT)) Q:(ABSPTRDT="")!(ABSPOUT)  D

 .M ABSPTMP(ABSPTRDT)=^TMP("ABSPOSRT",$J,ABSPTRDT)

 .S ABSPPPHM=""

 .S Y=ABSPTRDT

 .D DD^%DT

 .S ABSPFRDT=Y   ; FORMATTED DATE

 .S ABSPPPHM=""

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

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

 ..I ABSPPHMN="" S ABSPPHMN="UKN"

 ..Q:ABSPOUT

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

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

 ..Q:ABSPOUT

 ..S ABSPUSER=""

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

 ...S ABSPUSRN="UKN"

 ...S:ABSPUSER>0 ABSPUSRN=$P($G(^VA(200,ABSPUSER,0)),"^",1)

 ...S ABSPOUT=$$WRITE^ABSPOSUU("!!,?5,""POS USER: "",ABSPUSRN")

 ...Q:ABSPOUT

 ...S ABSPRESC=""

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

 ....I '$D(ABSPREST(ABSPRESC)) D

 .....S ABSPRXGT=ABSPRXGT+1

 .....S ABSPREST(ABSPRESC)=""

 ....S ABSPDATE(ABSPTRDT,"RX")=$G(ABSPDATE(ABSPTRDT,"RX"))+1

 ....S ABSPHARM(ABSPTRDT,ABSPPPHM,"RX")=$G(ABSPHARM(ABSPTRDT,ABSPPPHM,"RX"))+1

 ....S ABSPUSR(ABSPTRDT,ABSPPPHM,ABSPUSER,"RX")=$G(ABSPUSR(ABSPTRDT,ABSPPPHM,ABSPUSER,"RX"))+1

 ....S ABSPPRX=$P(ABSPRESC,".")

 ....S ABSPCLMI=ABSPCLM(ABSPRESC)

 ....I ABSPCLMI="" S ABSPPRXR=0

 ....E  S ABSPPRXR=$P($P(^ABSPC(ABSPCLMI,400,$P(^ABSPC(ABSPCLMI,400,0),U,3),400),U,3),"D3",2)

 ....S ABSPOTH=$$OTHERS(ABSPRESC,ABSPSTRT,ABSPEND)

 ....I ABSPOTH S ABSPPRXR=ABSPPRXR_" **"

 ....S ABSPOUT=$$WRITE^ABSPOSUU("!!,?25,""RX/REFILL: "",ABSPPRX,""/"",ABSPPRXR")

 ....Q:ABSPOUT

 ....D PRNTDHD

 ....S ABSPTRN=""

 ....F  S ABSPTRN=$O(ABSPTMP(ABSPTRDT,ABSPPPHM,ABSPUSER,ABSPRESC,ABSPTRN)) Q:(ABSPTRN="")!(ABSPOUT)  D

 .....S ABSPSBGT=ABSPSBGT+1

 .....S ABSPDATE(ABSPTRDT,"SUB")=$G(ABSPDATE(ABSPTRDT,"SUB"))+1

 .....S ABSPHARM(ABSPTRDT,ABSPPPHM,"SUB")=$G(ABSPHARM(ABSPTRDT,ABSPPPHM,"SUB"))+1

 .....S ABSPUSR(ABSPTRDT,ABSPPPHM,ABSPUSER,"SUB")=$G(ABSPUSR(ABSPTRDT,ABSPPPHM,ABSPUSER,"SUB"))+1

 .....S STRING=ABSPTMP(ABSPTRDT,ABSPPPHM,ABSPUSER,ABSPRESC,ABSPTRN)

 .....S ABSPSUB=$P(STRING,U)

 .....S ABSPTYP=$P(STRING,U,2)

 .....S ABSPRJCD=$P(STRING,U,3)

 .....S ABSPREA=$P(STRING,U,4)

 .....S ABSPBAMT=$P(STRING,U,5)

 .....S ABSPPAID=$P(STRING,U,6)

 .....S ABSPPRI=$P(STRING,U,7)

 .....I (ABSPPRI'="")&&('$D(ABSPRESP(ABSPPRI))) D

 ......S ABSPAID1=ABSPPAID

 ......S ABSPRESP(ABSPPRI)=""

 .....E  S ABSPAID1=0

 .....S ABSPAYGT=ABSPAYGT+ABSPPAID

 .....S ABSPDATE(ABSPTRDT,"PAY")=$G(ABSPDATE("DT",ABSPTRDT,"PAY"))+ABSPAID1

 .....S ABSPHARM(ABSPTRDT,ABSPPPHM,"PAY")=$G(ABSPHARM(ABSPTRDT,ABSPPPHM,"PAY"))+ABSPAID1

 .....S ABSPUSR(ABSPTRDT,ABSPPPHM,ABSPUSER,"PAY")=$G(ABSPUSR(ABSPTRDT,ABSPPPHM,ABSPUSER,"PAY"))+ABSPAID1

 .....S ABSPOUT=$$WRITE^ABSPOSUU("!,ABSPSUB,?14,ABSPTYP,?25,ABSPRJCD,?30,ABSPREA,?58,$J($FN(ABSPBAMT,"","",2),10),?70,$J($FN(ABSPPAID,"","",2),8)")

 ....Q:ABSPOUT

 ....I ABSPOTH S ABSPOUT=$$WRITE^ABSPOSUU("!!,""`**` Denotes this prescription has additional transactions "",!,?5,""outside the date range of this report.""")

 ...Q:ABSPOUT

 ...S ABSPOUT=$$WRITE^ABSPOSUU("!!,""FOR USER "",ABSPUSRN,"":""")

 ...Q:ABSPOUT

 ...S ABSPOUT=$$WRITE^ABSPOSUU("!,""Prescriptions: "",ABSPUSR(ABSPTRDT,ABSPPPHM,ABSPUSER,""RX"")")

 ...Q:ABSPOUT

 ...S ABSPOUT=$$WRITE^ABSPOSUU("!,""POS Submissions: "",ABSPUSR(ABSPTRDT,ABSPPPHM,ABSPUSER,""SUB"")")

 ...Q:ABSPOUT

 ...S ABSPOUT=$$WRITE^ABSPOSUU("!,""Total Paid: $"",$J($FN(ABSPUSR(ABSPTRDT,ABSPPPHM,ABSPUSER,""PAY""),"","",2),6)")

 ...Q:ABSPOUT

 ..Q:ABSPOUT

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

 ..Q:ABSPOUT

 ..S ABSPOUT=$$WRITE^ABSPOSUU("!,""Prescriptions: "",ABSPHARM(ABSPTRDT,ABSPPPHM,""RX"")")

 ..Q:ABSPOUT

 ..S ABSPOUT=$$WRITE^ABSPOSUU("!,""POS Submissions: "",ABSPHARM(ABSPTRDT,ABSPPPHM,""SUB"")")

 ..Q:ABSPOUT

 ..S ABSPOUT=$$WRITE^ABSPOSUU("!,""Total Paid: $"",$J($FN(ABSPHARM(ABSPTRDT,ABSPPPHM,""PAY""),"","",2),6)")

 ..Q:ABSPOUT

 .K ABSPTMP(ABSPTRDT)

 .Q:ABSPOUT

 .S ABSPOUT=$$WRITE^ABSPOSUU("!!,""FOR TRANSACTION DATE "",ABSPFRDT,"":""")

 .Q:ABSPOUT

 .S ABSPOUT=$$WRITE^ABSPOSUU("!,""Prescriptions: "",ABSPDATE(ABSPTRDT,""RX"")")

 .Q:ABSPOUT

 .S ABSPOUT=$$WRITE^ABSPOSUU("!,""POS Submissions: "",ABSPDATE(ABSPTRDT,""SUB"")")

 .Q:ABSPOUT

 .S ABSPOUT=$$WRITE^ABSPOSUU("!,""Total Paid: $"",$J($FN(ABSPDATE(ABSPTRDT,""PAY""),"","",2),6)")

 .Q:ABSPOUT

 S ABSPOUT=$$WRITE^ABSPOSUU("!!!,""Report Totals:""")

 Q:ABSPOUT

 S ABSPOUT=$$WRITE^ABSPOSUU("!!!,""Prescriptions: "",ABSPRXGT")

 Q:ABSPOUT

 S ABSPOUT=$$WRITE^ABSPOSUU("!,""POS Submissions: "",ABSPSBGT")

 Q:ABSPOUT

 S ABSPOUT=$$WRITE^ABSPOSUU("!,""Total Paid: $"",$J($FN(ABSPAYGT,"","",2),6)")

 Q:ABSPOUT

 Q

ZEND ; END AND KILL VARIABLES

 K ^TMP("ABSPOSRT",$J)

 D ^%ZISC

 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

 Q

BDT()  ; ENTER BEGINING DATE

 N ABSPBDT,DIR,X1,X,Y

 W !

 K DIR

 S DIR(0)="DEX"

 S DIR("A")="Enter Beginning POS Transaction 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,Y

 W !

 K DIR

 S DIR(0)="DEX"

 S DIR("A")="Enter Ending POS Transaction Date"

 D ^DIR

 I $D(DIRUT) Q -1

 S ABSPEDT=+Y

 S X1=ABSPEDT D C^%DTC

 Q X

OTHERS(ABSPRESC,ABSPSTRT,ABSPEND) ;CHECK FOR OTHER TRANSACTIONS OUTSIDE DATE RANGE

 ;See if there are any transactions outside the date range

 N X,ABSPTRN,ABSPDT,DONE

 S ABSPTRN=""

 S (X,DONE)=0

 F  S ABSPTRN=$O(^ABSPTL("B",ABSPRESC,ABSPTRN)) Q:(ABSPTRN="")!(DONE)  D

 . S ABSPDT=$P(^ABSPTL(ABSPTRN,0),U,8)

 . I (ABSPDT<ABSPSTRT)!(ABSPDT>ABSPEND) S (X,DONE)=1

 Q X

ABSPOSRT  ;IHS/OIT/CNI/RAN - Transaction History Report

 +1       ;;1.0;PHARMACY POINT OF SALE;**40,47**;JUN 21, 2001;Build 38

 +2       ; ABSP TRANSACTION HISTORY REPORT

 +3       ; DISPLAYS ALL TRANSACTIONS FOR A GIVEN PRESCRIPTION

EN        ; 

 +1        NEW ABSPQUIT,ABSPDONE,ABSPSTRT,ABSPEND,ABSPLCNT,ABSPREJ,ABSPRJ,U,ABSPTMP,ABSPTMPC,ABSPCLM,ABSPUSER,ABSPPPHM,X

 +2        SET U="^"

 +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

 +16                       QUIT 

                       End DoDot:2

 +17               IF ABSPQUIT

                       QUIT 

 +18               IF ABSPSTRT<0

                       SET ABSPDONE=1

                       QUIT 

 +19               IF ABSPEND<0

                       SET ABSPDONE=1

                       QUIT 

 +20               SET X2=ABSPSTRT

                   SET X1=ABSPEND

                   DO ^%DTC

 +21               IF X<0

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

 +22               IF X>=0

                       SET ABSPDONE=1

 +23               QUIT 

               End DoDot:1

 +24       IF ABSPQUIT

               QUIT 

 +25       SET ABSPQUIT=$$CLNC^ABSPOSUU()

 +26       IF ABSPQUIT=-1

               QUIT 

 +27       SET ABSPQUIT=$$USER^ABSPOSUU()

 +28       DO DEVSEL

 +29       IF ABSPQUIT=-1

               QUIT 

 +30       DO ^XBCLS

 +31       DO FIND

 +32       DO NEXT

 +33       QUIT 

DEVSEL    ; SELECT DEVICE

 +1        NEW ABSPSTOP

 +2        SET ABSPSTOP=0

 +3        DO ^%ZIS

 +4        IF POP

               Begin DoDot:1

 +5                DO ^%ZIS

 +6                QUIT 

               End DoDot:1

 +7        IF $DATA(DUOUT)

               Begin DoDot:1

 +8                DO ZEND

 +9                SET ABSPSTOP=1

 +10               QUIT 

               End DoDot:1

 +11       IF ABSPSTOP

               QUIT 

 +12       IF POP

               Begin DoDot:1

 +13               WRITE "DEVICE UNAVAILABLE"

                   GOTO DEVSEL

               End DoDot:1

 +14       QUIT 

FIND      ; FIND TRANSACTIONS BY TRANSACTION DATE USING "AH" CROSS REFERENCE

 +1        NEW ABSPRDT,ABSPDONE,ABSPDONE,ABSPTRN,ABSPTPTL,ABSPRESC,ABSPRESP

 +2        SET ABSPRDT=ABSPSTRT

 +3        SET ABSPEND=ABSPEND_".99999999"

 +4        SET ABSPDONE=0

 +5       ;GO THROUGH INDEX BY TRANSACTION DATE

 +6        FOR 

               SET ABSPRDT=$ORDER(^ABSPTL("AH",ABSPRDT))

               IF (ABSPRDT="")!(ABSPDONE)!(+ABSPRDT=0)

                   QUIT 

               Begin DoDot:1

 +7                IF ABSPRDT>ABSPEND

                       SET ABSPDONE=1

                       QUIT 

 +8                SET ABSPTRN=""

 +9                FOR 

                       SET ABSPTRN=$ORDER(^ABSPTL("AH",ABSPRDT,ABSPTRN))

                       IF (ABSPTRN="")!(ABSPDONE)

                           QUIT 

                       Begin DoDot:2

 +10                       SET ABSPRESC=$PIECE(^ABSPTL(ABSPTRN,0),U)

 +11                       DO GETINFO($PIECE(ABSPRDT,"."),ABSPTRN,ABSPRESC)

                       End DoDot:2

               End DoDot:1

 +12       QUIT 

GETINFO(ABSPRDT,ABSPTRN,ABSPRESC) ;GET ALL INFO FOR THIS PARTICULAR TRANSACTION

 +1        NEW ABSPTPTL,ABSPPRI,DO,ABSPTYPI,ABSPTTYP,ABSPRNUM,ABSPREA,ABSPBAMT,ABSPPHM1,ABSPPAID,ABSPUSR1,ABSPCLMI,ABSPORIG,ABSP9PTL,ABSP1PTL,ABSPTDT,ABSPTL

 +2        MERGE ABSPTL(ABSPTRN)=^ABSPTL(ABSPTRN)

 +3        SET ABSPTPTL=ABSPTL(ABSPTRN,0)

 +4        SET ABSP1PTL=ABSPTL(ABSPTRN,1)

 +5        SET ABSP9PTL=$GET(ABSPTL(ABSPTRN,9))

 +6        SET ABSPPRI=$PIECE(ABSPTPTL,U,5)

 +7        SET ABSPCLMI=$PIECE(ABSPTPTL,U,4)

 +8       ;NON ELECTRONIC...THIS IS A PAPER CLAIM

           IF ABSPPRI=""

               Begin DoDot:1

 +9                SET ABSPTTYP="PAPER"

 +10               SET (ABSPRNUM,ABSPREA)=""

 +11               SET ABSPPAID=0

 +12               IF '$DATA(ABSPTL(ABSPTRN,5))

                       SET ABSPTTYP="REVERSED"

                       SET ABSPBAMT=0

               End DoDot:1

 +13      ; SET PHARMACY

           SET ABSPPHM1=$PIECE(ABSP1PTL,U,7)

 +14      ; NOT SELECTED PHARMACY

           IF (ABSPPPHM'="ALL")&&(ABSPPHM1'=ABSPPPHM)

               QUIT 

 +15       IF ABSPPHM1=""

               SET ABSPPHM1=ABSPPPHM

 +16       SET ABSPUSR1=$PIECE(ABSPTPTL,U,17)

 +17      ; NOT SELECTED USER

           IF (ABSPUSER'="ALL")

               IF (ABSPUSR1'=ABSPUSER)

                   QUIT 

 +18       IF ABSPUSR1=""

               SET ABSPUSR1=ABSPUSER

 +19      ;Billed amount

           IF $DATA(ABSPTL(ABSPTRN,5))

               SET ABSPBAMT=$PIECE(ABSPTL(ABSPTRN,5),U,5)

 +20      IF '$TEST

               SET ABSPBAMT=0

 +21      ;SKIP ALL THIS IF WE HAVE PAPER CLAIM

           IF ABSPPRI'=""

               Begin DoDot:1

 +22               SET DO=$PIECE(ABSPTPTL,U,9)

 +23               IF '$DATA(^ABSPR(ABSPPRI,1000,DO))

                       SET DO=$$GETDO^ABSPOSUU(ABSPPRI,$PIECE(ABSPRESC,"."))

 +24               IF DO=""

                       QUIT 

 +25               SET ABSPTYPI=$PIECE(^ABSPR(ABSPPRI,1000,DO,500),U)

 +26               SET ABSPTTYP=$SELECT(ABSPTYPI="P":"PAYABLE",ABSPTYPI="R":"REJECTED",ABSPTYPI="D":"DUPLICATE",1:"PAPER")

 +27               SET (ABSPRNUM,ABSPREA)=""

 +28               IF ABSPTYPI="R"

                       Begin DoDot:2

 +29      ;Added to skip junk data in PMAA test area

                           IF '$DATA(^ABSPR(ABSPPRI,1000,DO,511))

                               SET (ABSPRNUM,ABSPREA)="UKN"

 +30                      IF '$TEST

                               Begin DoDot:3

 +31                               SET ABSPRNUM=$PIECE(^ABSPR(ABSPPRI,1000,DO,511,1,0),U)

 +32      ;IHS/OIT/RCS PATCH 47

                                   IF '$DATA(^ABSPF(9002313.93,"B",ABSPRNUM))

                                       SET ABSPREA="Reject Code description not entered,See NCPDP Rejects"

                                       QUIT 

 +33                               SET ABSPREA=$PIECE(^ABSPF(9002313.93,$ORDER(^ABSPF(9002313.93,"B",ABSPRNUM,"")),0),U,2)

                               End DoDot:3

 +34                       SET ABSPPAID=0

                       End DoDot:2

 +35               IF ABSPTYPI="P"

                       Begin DoDot:2

 +36                       SET ABSPPAID=$$DFF2EXT^ABSPECFM($PIECE(^ABSPR(ABSPPRI,1000,DO,500),U,9))

                           SET ABSPRESP(ABSPPRI)=""

 +37                       SET (ABSPRNUM,ABSPREA)=""

                       End DoDot:2

 +38               IF ABSPTYPI="D"

                       SET ABSPPAID=0

               End DoDot:1

 +39       IF ABSP9PTL'=""

               Begin DoDot:1

 +40               SET ABSPTDT=$PIECE(ABSPTPTL,U,8)

 +41               IF $PIECE(ABSP9PTL,U)=1

                       SET ABSPTTYP="CLOSED"

                       SET ABSPRNUM=""

                       SET ABSPREA=""

                       SET ABSPBAMT=0

                       SET ABSPPAID=0

 +42               IF ($PIECE(ABSP9PTL,U)=0)&($PIECE(ABSP9PTL,U,4)=ABSPTDT)

                       SET ABSPTTYP="REOPENED"

               End DoDot:1

 +43       IF $GET(ABSPTTYP)=""

               QUIT 

 +44       IF '$DATA(ABSPTMPC(ABSPRESC))

               SET ABSPTMPC(ABSPRESC)=1

 +45      IF '$TEST

               SET ABSPTMPC(ABSPRESC)=ABSPTMPC(ABSPRESC)+1

 +46       SET ^TMP("ABSPOSRT",$JOB,ABSPRDT,ABSPPHM1,ABSPUSR1,ABSPRESC,ABSPTRN)=ABSPTMPC(ABSPRESC)_U_ABSPTTYP_U_ABSPRNUM_U_ABSPREA_U_ABSPBAMT_U_ABSPPAID_U_ABSPPRI

 +47       SET ABSPCLM(ABSPRESC)=ABSPCLMI

 +48       QUIT 

NEXT      ; WHAT TO DO NEXT

 +1        NEW ABSPSTOP,ABSPOUT

 +2        SET (ABSPSTOP,ABSPOUT)=0

 +3        DO PRHDR

 +4        IF $ORDER(^TMP("ABSPOSRT",$JOB,""))=""

               Begin DoDot:1

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

 +6                DO ZEND

 +7                SET ABSPSTOP=1

 +8                QUIT 

               End DoDot:1

 +9        IF ABSPSTOP

               QUIT 

 +10       IF ABSPOUT

               DO ZEND

               QUIT 

 +11       DO PRNTDTL

 +12       DO ZEND

 +13       QUIT 

PRHDR     ; PRINT HEADER

 +1        NEW ABSPFEDT,ABSPFBDT,Y

 +2        USE IO

           IF $DATA(ABSPSUM)

               WRITE @IOF

 +3        SET Y=ABSPSTRT

 +4        DO DD^%DT

 +5        SET ABSPFBDT=Y

 +6        SET Y=$PIECE(ABSPEND,".")

 +7        DO DD^%DT

 +8        SET ABSPFEDT=Y

 +9        WRITE @IOF

 +10       WRITE !,?16,"Pharmacy Point of Sale Transaction History Report"

 +11       WRITE !?22,"From: "_ABSPFBDT_" TO: "_ABSPFEDT

 +12       WRITE !?18,"Pharmacy: "_ABSPPPHM

 +13       WRITE !?22,"User: "_ABSPUSER

 +14       QUIT 

PRNTDHD   ; PRINT HEADER

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

 +2        SET ABSPOUT=$$WRITE^ABSPOSUU("!,""SUBMISSION"",?14,""STATUS"",?25,""REJ"",?30,""REJ REASON"",?58,""BILLED AMT"",?70,""PAID AMT""")

 +3        IF ABSPOUT

               QUIT 

 +4        QUIT 

PRNTDTL   ; PRINT DETAIL

 +1        NEW ABSPTRDT,ABSPOUT,Y,ABSPFRDT,ABSPPPHM,ABSPPHMN,ABSPRESC,ABSPTRN,STRING,ABSPSUB,ABSPTYP,ABSPRJCD,ABSPREA,ABSPBAMT,ABSPPAID,ABSPUSRN

 +2        NEW ABSPRXGT,ABSPSBGT,ABSPAYGT,ABSPDATE,ABSPUSR,ABSPHARM,ABSPRESP,ABSPREST,ABSPAID1,ABSPUSER,ABSPCLMI,ABSPPRI,ABSPPRX,ABSPPRXR,ABSPOTH

 +3        SET (ABSPRXGT,ABSPSBGT,ABSPAYGT)=0

 +4        SET (ABSPTRDT,ABSPOUT)=""

 +5        FOR 

               SET ABSPTRDT=$ORDER(^TMP("ABSPOSRT",$JOB,ABSPTRDT))

               IF (ABSPTRDT="")!(ABSPOUT)

                   QUIT 

               Begin DoDot:1

 +6                MERGE ABSPTMP(ABSPTRDT)=^TMP("ABSPOSRT",$JOB,ABSPTRDT)

 +7                SET ABSPPPHM=""

 +8                SET Y=ABSPTRDT

 +9                DO DD^%DT

 +10      ; FORMATTED DATE

                   SET ABSPFRDT=Y

 +11               SET ABSPPPHM=""

 +12               FOR 

                       SET ABSPPPHM=$ORDER(ABSPTMP(ABSPTRDT,ABSPPPHM))

                       IF (ABSPPPHM="")!(ABSPOUT)

                           QUIT 

                       Begin DoDot:2

 +13                       SET ABSPPHMN=$PIECE($GET(^ABSP(9002313.56,ABSPPPHM,0)),U,1)

 +14                       IF ABSPPHMN=""

                               SET ABSPPHMN="UKN"

 +15                       IF ABSPOUT

                               QUIT 

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

 +17                       SET ABSPOUT=$$WRITE^ABSPOSUU("!!,?5,""PHARMACY: "",ABSPPHMN,""   TRANSACTION DATE: "",ABSPFRDT")

 +18                       IF ABSPOUT

                               QUIT 

 +19                       SET ABSPUSER=""

 +20                       FOR 

                               SET ABSPUSER=$ORDER(ABSPTMP(ABSPTRDT,ABSPPPHM,ABSPUSER))

                               IF (ABSPUSER="")!(ABSPOUT)

                                   QUIT 

                               Begin DoDot:3

 +21                               SET ABSPUSRN="UKN"

 +22                               IF ABSPUSER>0

                                       SET ABSPUSRN=$PIECE($GET(^VA(200,ABSPUSER,0)),"^",1)

 +23                               SET ABSPOUT=$$WRITE^ABSPOSUU("!!,?5,""POS USER: "",ABSPUSRN")

 +24                               IF ABSPOUT

                                       QUIT 

 +25                               SET ABSPRESC=""

 +26                               FOR 

                                       SET ABSPRESC=$ORDER(ABSPTMP(ABSPTRDT,ABSPPPHM,ABSPUSER,ABSPRESC))

                                       IF (ABSPRESC="")!(ABSPOUT)

                                           QUIT 

                                       Begin DoDot:4

 +27                                       IF '$DATA(ABSPREST(ABSPRESC))

                                               Begin DoDot:5

 +28                                               SET ABSPRXGT=ABSPRXGT+1

 +29                                               SET ABSPREST(ABSPRESC)=""

                                               End DoDot:5

 +30                                       SET ABSPDATE(ABSPTRDT,"RX")=$GET(ABSPDATE(ABSPTRDT,"RX"))+1

 +31                                       SET ABSPHARM(ABSPTRDT,ABSPPPHM,"RX")=$GET(ABSPHARM(ABSPTRDT,ABSPPPHM,"RX"))+1

 +32                                       SET ABSPUSR(ABSPTRDT,ABSPPPHM,ABSPUSER,"RX")=$GET(ABSPUSR(ABSPTRDT,ABSPPPHM,ABSPUSER,"RX"))+1

 +33                                       SET ABSPPRX=$PIECE(ABSPRESC,".")

 +34                                       SET ABSPCLMI=ABSPCLM(ABSPRESC)

 +35                                       IF ABSPCLMI=""

                                               SET ABSPPRXR=0

 +36                                      IF '$TEST

                                               SET ABSPPRXR=$PIECE($PIECE(^ABSPC(ABSPCLMI,400,$PIECE(^ABSPC(ABSPCLMI,400,0),U,3),400),U,3),"D3",2)

 +37                                       SET ABSPOTH=$$OTHERS(ABSPRESC,ABSPSTRT,ABSPEND)

 +38                                       IF ABSPOTH

                                               SET ABSPPRXR=ABSPPRXR_" **"

 +39                                       SET ABSPOUT=$$WRITE^ABSPOSUU("!!,?25,""RX/REFILL: "",ABSPPRX,""/"",ABSPPRXR")

 +40                                       IF ABSPOUT

                                               QUIT 

 +41                                       DO PRNTDHD

 +42                                       SET ABSPTRN=""

 +43                                       FOR 

                                               SET ABSPTRN=$ORDER(ABSPTMP(ABSPTRDT,ABSPPPHM,ABSPUSER,ABSPRESC,ABSPTRN))

                                               IF (ABSPTRN="")!(ABSPOUT)

                                                   QUIT 

                                               Begin DoDot:5

 +44                                               SET ABSPSBGT=ABSPSBGT+1

 +45                                               SET ABSPDATE(ABSPTRDT,"SUB")=$GET(ABSPDATE(ABSPTRDT,"SUB"))+1

 +46                                               SET ABSPHARM(ABSPTRDT,ABSPPPHM,"SUB")=$GET(ABSPHARM(ABSPTRDT,ABSPPPHM,"SUB"))+1

 +47                                               SET ABSPUSR(ABSPTRDT,ABSPPPHM,ABSPUSER,"SUB")=$GET(ABSPUSR(ABSPTRDT,ABSPPPHM,ABSPUSER,"SUB"))+1

 +48                                               SET STRING=ABSPTMP(ABSPTRDT,ABSPPPHM,ABSPUSER,ABSPRESC,ABSPTRN)

 +49                                               SET ABSPSUB=$PIECE(STRING,U)

 +50                                               SET ABSPTYP=$PIECE(STRING,U,2)

 +51                                               SET ABSPRJCD=$PIECE(STRING,U,3)

 +52                                               SET ABSPREA=$PIECE(STRING,U,4)

 +53                                               SET ABSPBAMT=$PIECE(STRING,U,5)

 +54                                               SET ABSPPAID=$PIECE(STRING,U,6)

 +55                                               SET ABSPPRI=$PIECE(STRING,U,7)

 +56                                               IF (ABSPPRI'="")&&('$DATA(ABSPRESP(ABSPPRI)))

                                                       Begin DoDot:6

 +57                                                       SET ABSPAID1=ABSPPAID

 +58                                                       SET ABSPRESP(ABSPPRI)=""

                                                       End DoDot:6

 +59                                              IF '$TEST

                                                       SET ABSPAID1=0

 +60                                               SET ABSPAYGT=ABSPAYGT+ABSPPAID

 +61                                               SET ABSPDATE(ABSPTRDT,"PAY")=$GET(ABSPDATE("DT",ABSPTRDT,"PAY"))+ABSPAID1

 +62                                               SET ABSPHARM(ABSPTRDT,ABSPPPHM,"PAY")=$GET(ABSPHARM(ABSPTRDT,ABSPPPHM,"PAY"))+ABSPAID1

 +63                                               SET ABSPUSR(ABSPTRDT,ABSPPPHM,ABSPUSER,"PAY")=$GET(ABSPUSR(ABSPTRDT,ABSPPPHM,ABSPUSER,"PAY"))+ABSPAID1

 +64                                               SET ABSPOUT=$$WRITE^ABSPOSUU("!,ABSPSUB,?14,ABSPTYP,?25,ABSPRJCD,?30,ABSPREA,?58,$J($FN(ABSPBAMT,"","",2),10),?70,$J($FN(ABSPPAID,"","",2),8)")

                                               End DoDot:5

 +65                                       IF ABSPOUT

                                               QUIT 

 +66                                       IF ABSPOTH

                                               SET ABSPOUT=$$WRITE^ABSPOSUU("!!,""`**` Denotes this prescription has additional transactions "",!,?5,""outside the date range of this report.""")

                                       End DoDot:4

 +67                               IF ABSPOUT

                                       QUIT 

 +68                               SET ABSPOUT=$$WRITE^ABSPOSUU("!!,""FOR USER "",ABSPUSRN,"":""")

 +69                               IF ABSPOUT

                                       QUIT 

 +70                               SET ABSPOUT=$$WRITE^ABSPOSUU("!,""Prescriptions: "",ABSPUSR(ABSPTRDT,ABSPPPHM,ABSPUSER,""RX"")")

 +71                               IF ABSPOUT

                                       QUIT 

 +72                               SET ABSPOUT=$$WRITE^ABSPOSUU("!,""POS Submissions: "",ABSPUSR(ABSPTRDT,ABSPPPHM,ABSPUSER,""SUB"")")

 +73                               IF ABSPOUT