ABPACKS0 ;AO PVT-INS CHECK SUMMARY DISPLAY; [ 06/26/91 7:56 AM ]
;;1.4;AO PVT-INS TRACKING;*0*;IHS-OKC/KJR;JULY 25, 1991
W !!,"<<< NOT AN ENTRY POINT - ACCESS DENIED >>>",!! Q
;---------------------------------------------------------------------
CLEAR ;PROCEDURE TO KILL ALL TEMPORARY VARIABLES
K I,GOTCHECK,RESTRICT,ABPACHK
Q
;---------------------------------------------------------------------
HEAD ;PROCEDURE TO DRAW SCREEN HEADING
K ABPA("HD") S ABPA("HD",1)=ABPATLE,ABPA("HD",2)=$P(XQO,"^",2)
D ^ABPAHD
Q
;---------------------------------------------------------------------
GETCHK ;PROCEDURE PROCESS INPUT OF A CHECK NUMBER
F I=0:0 D Q:(GOTCHECK)!(('GOTCHECK)&((Y="")!(Y["^"))) W *7," ??"
.S RESTRICT=0 W !! D MAIN^ABPACKLK
.I $D(ABPACHK)=1 I ABPACHK]""&('GOTCHECK) S Y=" "
I GOTCHECK D
.S ABPA("DTIN")=ABPACHK("XMIT") D DTCVT^ABPAMAIN
.S ABPACHK("RCVD")=ABPA("DTOUT")
Q
;---------------------------------------------------------------------
DEVICE ;PROCEDURE TO PROCESS OUTPUT DEVICE SELECTION
K %IS S %IS="H",%IS("A")="Use which device: " W ! D ^%ZIS U IO
Q
;---------------------------------------------------------------------
HEAD2 ;PROCEDURE TO DRAW CHECK SUMMARY HEADER
S ABPAPG=ABPAPG+1 W @IOF,!
S ABPA("DTIN")=DT D DTCVT^ABPAMAIN W ABPA("DTOUT")
S X=ABPATLE_" - Check Summary" W ?40-($L(X)/2),X
S X="Page ("_ABPAPG_")" W ?79-$L(X),X,!
F I=1:1:79 W "=" I I=79 W !
W " Check #: ",ABPACHK("NUM")," for ",$E(ABPACHK("APNAM"),1,27)
W ?56,"Amount: ",$J(ABPACHK("AMT"),8,2)
W !," Payor: ",ABPACHK("PAYOR"),?55,"Balance: "
W $J(ABPACHK("RAMT"),8,2),!,"Received: ",ABPACHK("RCVD"),?53
W "Last User: ",ABPACHK("LUSR"),! F I=1:1:79 W "=" I I=79 W !
W "Facility",?13,"Patient Name",?38,"DOS Beg/End",?54
W "Amount Insurer Name",!
Q
;---------------------------------------------------------------------
DETAIL ;PROCEDURE TO EXTRACT AND WRITE OUT THE DETAIL RECORDS
S DA(2)=0,ABPA("TAMT")=0,ABPAX=""
F ABPAI=0:0 D Q:+DA(2)=0!(ABPAX="^")
.S DA(2)=$O(^ABPVAO("CK",ABPACHK("NUM"),DA(2))) Q:+DA(2)=0 S DA(1)=0
.F ABPAJ=0:0 D Q:+DA(1)=0!(ABPAX="^")
..S DA(1)=$O(^ABPVAO("CK",ABPACHK("NUM"),DA(2),DA(1))) Q:+DA(1)=0
..S ABPA("PAT")="",ABPA("FAC")="" I $D(^ABPVAO(DA(2),0))=1 D
...S DATA=^ABPVAO(DA(2),0),ABPA("PAT")=$P(DATA,"^")
...S ABPAPTR=$P(DATA,"^",2) Q:$D(^AUTTLOC(ABPAPTR,0))'=1
...I $P(^AUTTLOC(ABPAPTR,0),"^",4)'=ABPACHK("AP") S ABPAX="^" Q
...S DATA=^AUTTLOC(ABPAPTR,0),ABPA("FAC")=$P(DATA,"^",2)
..I ABPAX="^" S ABPAX="" Q
..S ABPA("BDOS")=9999999,ABPA("EDOS")=0,ABPA("INS")=""
..I $D(^ABPVAO(DA(2),"P",DA(1),"D",0))=1 D
...S DA=0 F ABPAK=0:0 D Q:+DA=0
....S DA=$O(^ABPVAO(DA(2),"P",DA(1),"D",DA)) Q:+DA=0
....Q:$D(^ABPVAO(DA(2),"P",DA(1),"D",DA,0))'=1
....S ABPA("DOS")=+^ABPVAO(DA(2),"P",DA(1),"D",DA,0)
....I ABPA("DOS")<ABPA("BDOS") S ABPA("BDOS")=ABPA("DOS")
....I ABPA("DOS")>ABPA("EDOS") S ABPA("EDOS")=ABPA("DOS")
....S ABPAPTR=$P(^ABPVAO(DA(2),"P",DA(1),"D",DA,0),"^",2)
....Q:$D(^ABPVAO(DA(2),1,ABPAPTR,0))'=1
....S ABPAPTR=$P(^ABPVAO(DA(2),1,ABPAPTR,0),"^",6)
....Q:$D(^AUTNINS(ABPAPTR,0))'=1
....S ABPA("INS")=$E($P(^AUTNINS(ABPAPTR,0),"^"),1,18)
..S ABPA("DTIN")=ABPA("BDOS") D DTCVT^ABPAMAIN
..S ABPA("BDOS")=ABPA("DTOUT")
..S ABPA("DTIN")=ABPA("EDOS") D DTCVT^ABPAMAIN
..S ABPA("EDOS")=ABPA("DTOUT"),ABPA("AMT")=0
..I $D(^ABPVAO(DA(2),"P",DA(1),"A",0))=1 D
...S DA=0 F ABPAK=0:0 D Q:+DA=0
....S DA=$O(^ABPVAO(DA(2),"P",DA(1),"A",DA)) Q:+DA=0
....Q:$D(^ABPVAO(DA(2),"P",DA(1),"A",DA,0))'=1
....Q:$P(^ABPVAO(DA(2),"P",DA(1),"A",DA,0),"^",2)'="S"
....S ABPA("AMT")=ABPA("AMT")+(+^ABPVAO(DA(2),"P",DA(1),"A",DA,0))
..S ABPA("TAMT")=ABPA("TAMT")+ABPA("AMT")
..W !,ABPA("FAC"),?13,$E(ABPA("PAT"),1,20),?34,$J(ABPA("BDOS"),8)
..W " ",$J(ABPA("EDOS"),8),?52,$J(ABPA("AMT"),8,2),?61,ABPA("INS")
..I $Y>(IOSL-3) D Q:ABPAX="^" D HEAD2
...I $E(IOST,1)'="P" D
....S ABPAMESS="...Press any key to continue or ""^"" to exit..."
....U IO(0) D PAUSE^ABPAMAIN U IO
Q:ABPAX="^" I ABPA("TAMT")=0 D Q
.W !!,"No payments found using this check for this accounting point."
W !?52,"--------",!?52,$J(ABPA("TAMT"),8,2)
Q
;---------------------------------------------------------------------
CLOSE ;PROCEDURE TO PROCESS OUTPUT DEVICE CLOSING
U IO W ! X ^%ZIS("C") S IOP=$I D ^%ZIS K IOP
Q
;---------------------------------------------------------------------
MAIN ;THE OVERALL ROUTINE DRIVER - ENTRY POINT TO THIS PROGRAM
D CLEAR,HEAD,GETCHK I 'GOTCHECK D CLEAR Q
D DEVICE I $E(IOST,1)="P" U IO(0) W ! D WAIT^DICD U IO
S ABPAPG=0 D HEAD2,DETAIL,CLOSE G:ABPAX="^" MAIN
D PAUSE^ABPAMAIN
G MAIN
ABPACKS0 ;AO PVT-INS CHECK SUMMARY DISPLAY; [ 06/26/91 7:56 AM ]
+1 ;;1.4;AO PVT-INS TRACKING;*0*;IHS-OKC/KJR;JULY 25, 1991
+2 WRITE !!,"<<< NOT AN ENTRY POINT - ACCESS DENIED >>>",!!
QUIT
+3 ;---------------------------------------------------------------------
CLEAR ;PROCEDURE TO KILL ALL TEMPORARY VARIABLES
+1 KILL I,GOTCHECK,RESTRICT,ABPACHK
+2 QUIT
+3 ;---------------------------------------------------------------------
HEAD ;PROCEDURE TO DRAW SCREEN HEADING
+1 KILL ABPA("HD")
SET ABPA("HD",1)=ABPATLE
SET ABPA("HD",2)=$PIECE(XQO,"^",2)
+2 DO ^ABPAHD
+3 QUIT
+4 ;---------------------------------------------------------------------
GETCHK ;PROCEDURE PROCESS INPUT OF A CHECK NUMBER
+1 FOR I=0:0
Begin DoDot:1
+2 SET RESTRICT=0
WRITE !!
DO MAIN^ABPACKLK
+3 IF $DATA(ABPACHK)=1
IF ABPACHK]""&('GOTCHECK)
SET Y=" "
End DoDot:1
IF (GOTCHECK)!(('GOTCHECK)&((Y="")!(Y["^")))
QUIT
WRITE *7," ??"
+4 IF GOTCHECK
Begin DoDot:1
+5 SET ABPA("DTIN")=ABPACHK("XMIT")
DO DTCVT^ABPAMAIN
+6 SET ABPACHK("RCVD")=ABPA("DTOUT")
End DoDot:1
+7 QUIT
+8 ;---------------------------------------------------------------------
DEVICE ;PROCEDURE TO PROCESS OUTPUT DEVICE SELECTION
+1 KILL %IS
SET %IS="H"
SET %IS("A")="Use which device: "
WRITE !
DO ^%ZIS
USE IO
+2 QUIT
+3 ;---------------------------------------------------------------------
HEAD2 ;PROCEDURE TO DRAW CHECK SUMMARY HEADER
+1 SET ABPAPG=ABPAPG+1
WRITE @IOF,!
+2 SET ABPA("DTIN")=DT
DO DTCVT^ABPAMAIN
WRITE ABPA("DTOUT")
+3 SET X=ABPATLE_" - Check Summary"
WRITE ?40-($LENGTH(X)/2),X
+4 SET X="Page ("_ABPAPG_")"
WRITE ?79-$LENGTH(X),X,!
+5 FOR I=1:1:79
WRITE "="
IF I=79
WRITE !
+6 WRITE " Check #: ",ABPACHK("NUM")," for ",$EXTRACT(ABPACHK("APNAM"),1,27)
+7 WRITE ?56,"Amount: ",$JUSTIFY(ABPACHK("AMT"),8,2)
+8 WRITE !," Payor: ",ABPACHK("PAYOR"),?55,"Balance: "
+9 WRITE $JUSTIFY(ABPACHK("RAMT"),8,2),!,"Received: ",ABPACHK("RCVD"),?53
+10 WRITE "Last User: ",ABPACHK("LUSR"),!
FOR I=1:1:79
WRITE "="
IF I=79
WRITE !
+11 WRITE "Facility",?13,"Patient Name",?38,"DOS Beg/End",?54
+12 WRITE "Amount Insurer Name",!
+13 QUIT
+14 ;---------------------------------------------------------------------
DETAIL ;PROCEDURE TO EXTRACT AND WRITE OUT THE DETAIL RECORDS
+1 SET DA(2)=0
SET ABPA("TAMT")=0
SET ABPAX=""
+2 FOR ABPAI=0:0
Begin DoDot:1
+3 SET DA(2)=$ORDER(^ABPVAO("CK",ABPACHK("NUM"),DA(2)))
IF +DA(2)=0
QUIT
SET DA(1)=0
+4 FOR ABPAJ=0:0
Begin DoDot:2
+5 SET DA(1)=$ORDER(^ABPVAO("CK",ABPACHK("NUM"),DA(2),DA(1)))
IF +DA(1)=0
QUIT
+6 SET ABPA("PAT")=""
SET ABPA("FAC")=""
IF $DATA(^ABPVAO(DA(2),0))=1
Begin DoDot:3
+7 SET DATA=^ABPVAO(DA(2),0)
SET ABPA("PAT")=$PIECE(DATA,"^")
+8 SET ABPAPTR=$PIECE(DATA,"^",2)
IF $DATA(^AUTTLOC(ABPAPTR,0))'=1
QUIT
+9 IF $PIECE(^AUTTLOC(ABPAPTR,0),"^",4)'=ABPACHK("AP")
SET ABPAX="^"
QUIT
+10 SET DATA=^AUTTLOC(ABPAPTR,0)
SET ABPA("FAC")=$PIECE(DATA,"^",2)
End DoDot:3
+11 IF ABPAX="^"
SET ABPAX=""
QUIT
+12 SET ABPA("BDOS")=9999999
SET ABPA("EDOS")=0
SET ABPA("INS")=""
+13 IF $DATA(^ABPVAO(DA(2),"P",DA(1),"D",0))=1
Begin DoDot:3
+14 SET DA=0
FOR ABPAK=0:0
Begin DoDot:4
+15 SET DA=$ORDER(^ABPVAO(DA(2),"P",DA(1),"D",DA))
IF +DA=0
QUIT
+16 IF $DATA(^ABPVAO(DA(2),"P",DA(1),"D",DA,0))'=1
QUIT
+17 SET ABPA("DOS")=+^ABPVAO(DA(2),"P",DA(1),"D",DA,0)
+18 IF ABPA("DOS")<ABPA("BDOS")
SET ABPA("BDOS")=ABPA("DOS")
+19 IF ABPA("DOS")>ABPA("EDOS")
SET ABPA("EDOS")=ABPA("DOS")
+20 SET ABPAPTR=$PIECE(^ABPVAO(DA(2),"P",DA(1),"D",DA,0),"^",2)
+21 IF $DATA(^ABPVAO(DA(2),1,ABPAPTR,0))'=1
QUIT
+22 SET ABPAPTR=$PIECE(^ABPVAO(DA(2),1,ABPAPTR,0),"^",6)
+23 IF $DATA(^AUTNINS(ABPAPTR,0))'=1
QUIT
+24 SET ABPA("INS")=$EXTRACT($PIECE(^AUTNINS(ABPAPTR,0),"^"),1,18)
End DoDot:4
IF +DA=0
QUIT
End DoDot:3
+25 SET ABPA("DTIN")=ABPA("BDOS")
DO DTCVT^ABPAMAIN
+26 SET ABPA("BDOS")=ABPA("DTOUT")
+27 SET ABPA("DTIN")=ABPA("EDOS")
DO DTCVT^ABPAMAIN
+28 SET ABPA("EDOS")=ABPA("DTOUT")
SET ABPA("AMT")=0
+29 IF $DATA(^ABPVAO(DA(2),"P",DA(1),"A",0))=1
Begin DoDot:3
+30 SET DA=0
FOR ABPAK=0:0
Begin DoDot:4
+31 SET DA=$ORDER(^ABPVAO(DA(2),"P",DA(1),"A",DA))
IF +DA=0
QUIT
+32 IF $DATA(^ABPVAO(DA(2),"P",DA(1),"A",DA,0))'=1
QUIT
+33 IF $PIECE(^ABPVAO(DA(2),"P",DA(1),"A",DA,0),"^",2)'="S"
QUIT
+34 SET ABPA("AMT")=ABPA("AMT")+(+^ABPVAO(DA(2),"P",DA(1),"A",DA,0))
End DoDot:4
IF +DA=0
QUIT
End DoDot:3
+35 SET ABPA("TAMT")=ABPA("TAMT")+ABPA("AMT")
+36 WRITE !,ABPA("FAC"),?13,$EXTRACT(ABPA("PAT"),1,20),?34,$JUSTIFY(ABPA("BDOS"),8)
+37 WRITE " ",$JUSTIFY(ABPA("EDOS"),8),?52,$JUSTIFY(ABPA("AMT"),8,2),?61,ABPA("INS")
+38 IF $Y>(IOSL-3)
Begin DoDot:3
+39 IF $EXTRACT(IOST,1)'="P"
Begin DoDot:4
+40 SET ABPAMESS="...Press any key to continue or ""^"" to exit..."
+41 USE IO(0)
DO PAUSE^ABPAMAIN
USE IO
End DoDot:4
End DoDot:3
IF ABPAX="^"
QUIT
DO HEAD2
End DoDot:2
IF +DA(1)=0!(ABPAX="^")
QUIT
End DoDot:1
IF +DA(2)=0!(ABPAX="^")
QUIT
+42 IF ABPAX="^"
QUIT
IF ABPA("TAMT")=0
Begin DoDot:1
+43 WRITE !!,"No payments found using this check for this accounting point."
End DoDot:1
QUIT
+44 WRITE !?52,"--------",!?52,$JUSTIFY(ABPA("TAMT"),8,2)
+45 QUIT
+46 ;---------------------------------------------------------------------
CLOSE ;PROCEDURE TO PROCESS OUTPUT DEVICE CLOSING
+1 USE IO
WRITE !
XECUTE ^%ZIS("C")
SET IOP=$IO
DO ^%ZIS
KILL IOP
+2 QUIT
+3 ;---------------------------------------------------------------------
MAIN ;THE OVERALL ROUTINE DRIVER - ENTRY POINT TO THIS PROGRAM
+1 DO CLEAR
DO HEAD
DO GETCHK
IF 'GOTCHECK
DO CLEAR
QUIT
+2 DO DEVICE
IF $EXTRACT(IOST,1)="P"
USE IO(0)
WRITE !
DO WAIT^DICD
USE IO
+3 SET ABPAPG=0
DO HEAD2
DO DETAIL
DO CLOSE
IF ABPAX="^"
GOTO MAIN
+4 DO PAUSE^ABPAMAIN
+5 GOTO MAIN
