ABPAPDD4 ;DELETE PAYMENT ENTRY; [ 07/09/91 7:55 AM ]
;;1.4;AO PVT-INS TRACKING;*0*;IHS-OKC/KJR;JULY 25, 1991
A0 K DIR S DIR(0)="YO",DIR("B")="YES"
S DIR("A")="DELETE THE CURRENT TRANSACTIONS - ARE YOUR SURE "
S DIR("A")=DIR("A")_"(Y/N)" W *7 D ^DIR I 'Y D G ^ABPAPDD1
.K ABPAMESS S ABPAMESS="Nothing deleted!"
.S ABPAMESS(2)="... Press any key to continue ... " D PAUSE^ABPAMAIN
A0A W !,"The '",ABPABDT,"' transactions for ",ABPAPAT," are being deleted "
;--------------------------------------------------------------------
A1 ;PROCEDURE TO RESET CLAIM FLAGS AND WRITE-OFF FIELDS
K DIC,DIE,DA,DR,DIK,ABPA("QF"),ABPADOS
S ABPADOS=0 F ABPA("I")=0:0 D Q:$D(ABPA("QF"))=1
.S ABPADOS=$O(^ABPVAO(ABPATDFN,"P",ABPADDFN,"D",ABPADOS))
.I +ABPADOS=0 S ABPA("QF")="" Q
.S DA=$P(^ABPVAO(ABPATDFN,"P",ABPADDFN,"D",ABPADOS,0),"^",2)
.Q:(+DA<1)!($D(^ABPVAO(ABPATDFN,1,DA,0))'=1)
.S ZDA=0 F ABPAPCNT=0:1 D I +ZDA=0 K ZDA Q
..S ZDA=$O(^ABPVAO("PD",ABPATDFN,DA,ZDA))
.I +ABPAPCNT<2 D
..K DIE,DR S DA(1)=ABPATDFN,DIE="^ABPVAO("_DA(1)_",1,",DR=".18///O"
..D ^DIE W "."
.I +ABPAPCNT>1 D
..K DIE,DR S DA(1)=ABPATDFN,DIE="^ABPVAO("_DA(1)_",1,"
..S DR=".18///"_$P(^ABPVAO(DA(1),1,DA,0),"^",17)
..D ^DIE W "."
.K DIE,DR S DA(1)=ABPATDFN,DIE="^ABPVAO("_DA(1)_",1,",DR=".03///@"
.D ^DIE
.Q
;--------------------------------------------------------------------
A2 ;PROCEDURE TO DELETE THE INSURER PAYMENT NODE
K DIC,DIE,DA,DR,DIK,ABPA("I"),ABPA("QF")
S DA(1)=ABPATDFN,DA=ABPADDFN,DIK="^ABPVAO("_DA(1)_",""P"","
D ^DIK W "."
;--------------------------------------------------------------------
A3 ;PROCEDURE TO ADJUST CHECK BALANCES
I ABPACHK]"" F I=0:0 D Q:GOTCHECK
.S (RESTRICT,GOTCHECK)=0,ABPASCR=""
.D LOOK^ABPACKLK,CLEAR^ABPACKLK I 'GOTCHECK D Q
..W *7,!?5,"<<< PLEASE SELECT THE APPROPRIATE CHECK >>>"
.K DIE,DA,DR S DA(2)=$O(ABPACHK("")),DA(1)=$O(ABPACHK(DA(2),""))
.S DA=$O(ABPACHK(DA(2),DA(1),""))
.S DIE="^ABPACHKS("_DA(2)_",""I"","_DA(1)_",""C"","
.S ABPACHK("RAMT")=ABPACHK("RAMT")+ABPA("STDAMT")
.S ABPACHK("PAMT")=ABPACHK("AMT")-ABPACHK("RAMT")
.S DR="6///"_$S(ABPACHK("PAMT")=0:"N",1:"P")
.S DR=DR_";7///"_ABPACHK("PAMT")_";8///"_ABPACHK("RAMT")
.S DR=DR_";9///"_DUZ_";10///NOW" D ^DIE
.K DIK S DIK=DIE D IX^DIK Q
;--------------------------------------------------------------------
L ^ABPVAO(ABPATDFN)
K GOTCHECK,ABPAMESS S ABPAMESS="Deletion Complete!"
S ABPAMESS(2)="... Press any key to continue ... " D PAUSE^ABPAMAIN
G ^ABPAPDD1
ABPAPDD4 ;DELETE PAYMENT ENTRY; [ 07/09/91 7:55 AM ]
+1 ;;1.4;AO PVT-INS TRACKING;*0*;IHS-OKC/KJR;JULY 25, 1991
A0 KILL DIR
SET DIR(0)="YO"
SET DIR("B")="YES"
+1 SET DIR("A")="DELETE THE CURRENT TRANSACTIONS - ARE YOUR SURE "
+2 SET DIR("A")=DIR("A")_"(Y/N)"
WRITE *7
DO ^DIR
IF 'Y
Begin DoDot:1
+3 KILL ABPAMESS
SET ABPAMESS="Nothing deleted!"
+4 SET ABPAMESS(2)="... Press any key to continue ... "
DO PAUSE^ABPAMAIN
End DoDot:1
GOTO ^ABPAPDD1
A0A WRITE !,"The '",ABPABDT,"' transactions for ",ABPAPAT," are being deleted "
+1 ;--------------------------------------------------------------------
A1 ;PROCEDURE TO RESET CLAIM FLAGS AND WRITE-OFF FIELDS
+1 KILL DIC,DIE,DA,DR,DIK,ABPA("QF"),ABPADOS
+2 SET ABPADOS=0
FOR ABPA("I")=0:0
Begin DoDot:1
+3 SET ABPADOS=$ORDER(^ABPVAO(ABPATDFN,"P",ABPADDFN,"D",ABPADOS))
+4 IF +ABPADOS=0
SET ABPA("QF")=""
QUIT
+5 SET DA=$PIECE(^ABPVAO(ABPATDFN,"P",ABPADDFN,"D",ABPADOS,0),"^",2)
+6 IF (+DA<1)!($DATA(^ABPVAO(ABPATDFN,1,DA,0))'=1)
QUIT
+7 SET ZDA=0
FOR ABPAPCNT=0:1
Begin DoDot:2
+8 SET ZDA=$ORDER(^ABPVAO("PD",ABPATDFN,DA,ZDA))
End DoDot:2
IF +ZDA=0
KILL ZDA
QUIT
+9 IF +ABPAPCNT<2
Begin DoDot:2
+10 KILL DIE,DR
SET DA(1)=ABPATDFN
SET DIE="^ABPVAO("_DA(1)_",1,"
SET DR=".18///O"
+11 DO ^DIE
WRITE "."
End DoDot:2
+12 IF +ABPAPCNT>1
Begin DoDot:2
+13 KILL DIE,DR
SET DA(1)=ABPATDFN
SET DIE="^ABPVAO("_DA(1)_",1,"
+14 SET DR=".18///"_$PIECE(^ABPVAO(DA(1),1,DA,0),"^",17)
+15 DO ^DIE
WRITE "."
End DoDot:2
+16 KILL DIE,DR
SET DA(1)=ABPATDFN
SET DIE="^ABPVAO("_DA(1)_",1,"
SET DR=".03///@"
+17 DO ^DIE
+18 QUIT
End DoDot:1
IF $DATA(ABPA("QF"))=1
QUIT
+19 ;--------------------------------------------------------------------
A2 ;PROCEDURE TO DELETE THE INSURER PAYMENT NODE
+1 KILL DIC,DIE,DA,DR,DIK,ABPA("I"),ABPA("QF")
+2 SET DA(1)=ABPATDFN
SET DA=ABPADDFN
SET DIK="^ABPVAO("_DA(1)_",""P"","
+3 DO ^DIK
WRITE "."
+4 ;--------------------------------------------------------------------
A3 ;PROCEDURE TO ADJUST CHECK BALANCES
+1 IF ABPACHK]""
FOR I=0:0
Begin DoDot:1
+2 SET (RESTRICT,GOTCHECK)=0
SET ABPASCR=""
+3 DO LOOK^ABPACKLK
DO CLEAR^ABPACKLK
IF 'GOTCHECK
Begin DoDot:2
+4 WRITE *7,!?5,"<<< PLEASE SELECT THE APPROPRIATE CHECK >>>"
End DoDot:2
QUIT
+5 KILL DIE,DA,DR
SET DA(2)=$ORDER(ABPACHK(""))
SET DA(1)=$ORDER(ABPACHK(DA(2),""))
+6 SET DA=$ORDER(ABPACHK(DA(2),DA(1),""))
+7 SET DIE="^ABPACHKS("_DA(2)_",""I"","_DA(1)_",""C"","
+8 SET ABPACHK("RAMT")=ABPACHK("RAMT")+ABPA("STDAMT")
+9 SET ABPACHK("PAMT")=ABPACHK("AMT")-ABPACHK("RAMT")
+10 SET DR="6///"_$SELECT(ABPACHK("PAMT")=0:"N",1:"P")
+11 SET DR=DR_";7///"_ABPACHK("PAMT")_";8///"_ABPACHK("RAMT")
+12 SET DR=DR_";9///"_DUZ_";10///NOW"
DO ^DIE
+13 KILL DIK
SET DIK=DIE
DO IX^DIK
QUIT
End DoDot:1
IF GOTCHECK
QUIT
+14 ;--------------------------------------------------------------------
+15 LOCK ^ABPVAO(ABPATDFN)
+16 KILL GOTCHECK,ABPAMESS
SET ABPAMESS="Deletion Complete!"
+17 SET ABPAMESS(2)="... Press any key to continue ... "
DO PAUSE^ABPAMAIN
+18 GOTO ^ABPAPDD1
