- 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
