- ABPACLG3 ;CHECK LOG UTILITY FUNCTIONS - PART 3; [ 06/26/91 7:26 PM ]
- ;;1.4;AO PVT-INS TRACKING;*0*;IHS-OKC/KJR;JULY 25, 1991
- Q ;;NOT AN ENTRY POINT
- START ;ENTRY POINT
- ;---------------------------------------------------------------------
- RETURN ;PROCEDURE TO PROCESS RETURNED CHECKS
- I ABPA("FUNC")="R" D G GETCHK^ABPACLG1
- .S DIR(0)="Y",DIR("A")=Y(0)_" NUMBER >>> "_ABPACHK("NUM")
- .S DIR("A")=DIR("A")_" <<< ARE YOU SURE"
- .D HEAD^ABPACLG1 S DX=0,DY=12
- .X XY D EOP^ABPAMAIN W *7 D ^DIR K DIR I 'Y D Q
- ..D CLEAR^ABPACLG1 K ABPACHK D HEAD^ABPACLG1
- .W ! D WAIT^DICD K DIC,DIE,DR,DA
- .S DA(2)=ABPADFN(1),DA(1)=ABPADFN(2),DA=ABPADFN(3)
- .S DIE="^ABPACHKS("_DA(2)_",""I"","_DA(1)_",""C"","
- .S DR="4///"_DUZ_";5///NOW;6///"_ABPA("FUNC")_";8///0"
- .D ^DIE K ^ABPACHKS("RB",ABPADFN(1),ABPADFN(2),ABPADFN(3))
- .I $D(^ABPACHKS(DA(2),"I",DA(1),"C",DA,"SP",0))'=1 D
- ..S ^ABPACHKS(DA(2),"I",DA(1),"C",DA,"SP",0)="^9002270.31113DA^^0"
- .S %DT="T",X="NOW" D ^%DT K DIC,DIE,DR
- .S DIC="^ABPACHKS("_DA(2)_",""I"","_DA(1)_",""C"","_DA_",""SP"","
- .K DA S DA(3)=ABPADFN(1),DA(2)=ABPADFN(2),DA(1)=ABPADFN(3)
- .S DIC(0)="LZ",X=Y D ^DIC S ABPADFN(4)=+Y K DIC,DIE,DA,DR
- .S DA(3)=ABPADFN(1),DA(2)=ABPADFN(2),DA(1)=ABPADFN(3),DA=ABPADFN(4)
- .S DIE="^ABPACHKS("_DA(3)_",""I"","_DA(2)_",""C"","_DA(1)_",""SP"","
- .S DR="1///"_ABPA("FUNC")_";2///"_DUZ_";3///"_ABPACHK("AMT")_";4"
- .W ! D ^DIE I ABPADFN(1)=1 D
- ..S ABPA("$P")=+$P(^ABPAPBAT($P(ABPACHK("XMIT"),"."),0),"^",12)
- ..S ABPA("$P")=ABPA("$P")+ABPACHK("AMT")
- ..S $P(^ABPAPBAT($P(ABPACHK("XMIT"),"."),0),"^",12)=ABPA("$P")
- .D CLEAR^ABPACLG1 K ABPACHK D HEAD^ABPACLG1
- ;--------------------------------------------------------------------
- TRANSFER ;PROCEDURE TO PROCESS CHECK TRANSFERS
- D HEAD^ABPACLG1 S DX=0,DY=12 X XY D EOP^ABPAMAIN W !,ABPA("FD")
- S MAX=ABPACHK("RAMT")
- S DIR(0)="NO^:"_MAX_":2",DIR("A")=" HOW MUCH"
- S DX=0,DY=14 X XY D EOP^ABPAMAIN D ^DIR K DIR S ABPA("AMT")=+Y
- I +ABPA("AMT")'>0 D G GETCHK^ABPACLG1
- .D CLEAR^ABPACLG1 K ABPACHK D HEAD^ABPACLG1
- S ABPA("TYPE")=2 I ABPA("AMT")=ABPACHK("AMT") S ABPA("TYPE")=1
- D HEAD^ABPACLG1 S DX=0,DY=12 X XY D EOP^ABPAMAIN W !,ABPA("FD")
- W " in the amount of $",$J(ABPA("AMT"),9,2),!
- K DIR,DIC,DIE,DA,DR
- S DIR(0)="PO^DIC(4,:EQZ",DIR("A")=" TO"
- S DIR("A",1)=" FROM: "_$P(^DIC(4,ACTPTR,0),"^") D ^DIR K DIR
- I 'Y D CLEAR^ABPACLG1 K ABPACHK D HEAD^ABPACLG1 G GETCHK^ABPACLG1
- S ABPA("TO")=+Y I ACTPTR=ABPA("TO") D G GETCHK^ABPACLG1
- .W *7,!?5,"<<< CANNOT TRANSFER TO THE SAME FACILITY >>>" H 3
- .D CLEAR^ABPACLG1 K ABPACHK D HEAD^ABPACLG1
- D HEAD^ABPACLG1 S DX=0,DY=12 X XY D EOP^ABPAMAIN
- W !?30,"Transfer Summary",!
- W !?3,"$",$J(ABPA("AMT"),9,2)," of check #",ABPACHK("NUM")
- W " from ",ABPAINS,!?3,"is to be transferred to "
- W $P(^DIC(4,ABPA("TO"),0),"^")
- S DIR(0)="Y",DIR("A")="Is this correct" W ! D ^DIR K DIR
- I 'Y D CLEAR^ABPACLG1 K ABPACHK D HEAD^ABPACLG1 G GETCHK^ABPACLG1
- G START^ABPACLG5
- ABPACLG3 ;CHECK LOG UTILITY FUNCTIONS - PART 3; [ 06/26/91 7:26 PM ]
- +1 ;;1.4;AO PVT-INS TRACKING;*0*;IHS-OKC/KJR;JULY 25, 1991
- +2 ;;NOT AN ENTRY POINT
- QUIT
- START ;ENTRY POINT
- +1 ;---------------------------------------------------------------------
- RETURN ;PROCEDURE TO PROCESS RETURNED CHECKS
- +1 IF ABPA("FUNC")="R"
- Begin DoDot:1
- +2 SET DIR(0)="Y"
- SET DIR("A")=Y(0)_" NUMBER >>> "_ABPACHK("NUM")
- +3 SET DIR("A")=DIR("A")_" <<< ARE YOU SURE"
- +4 DO HEAD^ABPACLG1
- SET DX=0
- SET DY=12
- +5 XECUTE XY
- DO EOP^ABPAMAIN
- WRITE *7
- DO ^DIR
- KILL DIR
- IF 'Y
- Begin DoDot:2
- +6 DO CLEAR^ABPACLG1
- KILL ABPACHK
- DO HEAD^ABPACLG1
- End DoDot:2
- QUIT
- +7 WRITE !
- DO WAIT^DICD
- KILL DIC,DIE,DR,DA
- +8 SET DA(2)=ABPADFN(1)
- SET DA(1)=ABPADFN(2)
- SET DA=ABPADFN(3)
- +9 SET DIE="^ABPACHKS("_DA(2)_",""I"","_DA(1)_",""C"","
- +10 SET DR="4///"_DUZ_";5///NOW;6///"_ABPA("FUNC")_";8///0"
- +11 DO ^DIE
- KILL ^ABPACHKS("RB",ABPADFN(1),ABPADFN(2),ABPADFN(3))
- +12 IF $DATA(^ABPACHKS(DA(2),"I",DA(1),"C",DA,"SP",0))'=1
- Begin DoDot:2
- +13 SET ^ABPACHKS(DA(2),"I",DA(1),"C",DA,"SP",0)="^9002270.31113DA^^0"
- End DoDot:2
- +14 SET %DT="T"
- SET X="NOW"
- DO ^%DT
- KILL DIC,DIE,DR
- +15 SET DIC="^ABPACHKS("_DA(2)_",""I"","_DA(1)_",""C"","_DA_",""SP"","
- +16 KILL DA
- SET DA(3)=ABPADFN(1)
- SET DA(2)=ABPADFN(2)
- SET DA(1)=ABPADFN(3)
- +17 SET DIC(0)="LZ"
- SET X=Y
- DO ^DIC
- SET ABPADFN(4)=+Y
- KILL DIC,DIE,DA,DR
- +18 SET DA(3)=ABPADFN(1)
- SET DA(2)=ABPADFN(2)
- SET DA(1)=ABPADFN(3)
- SET DA=ABPADFN(4)
- +19 SET DIE="^ABPACHKS("_DA(3)_",""I"","_DA(2)_",""C"","_DA(1)_",""SP"","
- +20 SET DR="1///"_ABPA("FUNC")_";2///"_DUZ_";3///"_ABPACHK("AMT")_";4"
- +21 WRITE !
- DO ^DIE
- IF ABPADFN(1)=1
- Begin DoDot:2
- +22 SET ABPA("$P")=+$PIECE(^ABPAPBAT($PIECE(ABPACHK("XMIT"),"."),0),"^",12)
- +23 SET ABPA("$P")=ABPA("$P")+ABPACHK("AMT")
- +24 SET $PIECE(^ABPAPBAT($PIECE(ABPACHK("XMIT"),"."),0),"^",12)=ABPA("$P")
- End DoDot:2
- +25 DO CLEAR^ABPACLG1
- KILL ABPACHK
- DO HEAD^ABPACLG1
- End DoDot:1
- GOTO GETCHK^ABPACLG1
- +26 ;--------------------------------------------------------------------
- TRANSFER ;PROCEDURE TO PROCESS CHECK TRANSFERS
- +1 DO HEAD^ABPACLG1
- SET DX=0
- SET DY=12
- XECUTE XY
- DO EOP^ABPAMAIN
- WRITE !,ABPA("FD")
- +2 SET MAX=ABPACHK("RAMT")
- +3 SET DIR(0)="NO^:"_MAX_":2"
- SET DIR("A")=" HOW MUCH"
- +4 SET DX=0
- SET DY=14
- XECUTE XY
- DO EOP^ABPAMAIN
- DO ^DIR
- KILL DIR
- SET ABPA("AMT")=+Y
- +5 IF +ABPA("AMT")'>0
- Begin DoDot:1
- +6 DO CLEAR^ABPACLG1
- KILL ABPACHK
- DO HEAD^ABPACLG1
- End DoDot:1
- GOTO GETCHK^ABPACLG1
- +7 SET ABPA("TYPE")=2
- IF ABPA("AMT")=ABPACHK("AMT")
- SET ABPA("TYPE")=1
- +8 DO HEAD^ABPACLG1
- SET DX=0
- SET DY=12
- XECUTE XY
- DO EOP^ABPAMAIN
- WRITE !,ABPA("FD")
- +9 WRITE " in the amount of $",$JUSTIFY(ABPA("AMT"),9,2),!
- +10 KILL DIR,DIC,DIE,DA,DR
- +11 SET DIR(0)="PO^DIC(4,:EQZ"
- SET DIR("A")=" TO"
- +12 SET DIR("A",1)=" FROM: "_$PIECE(^DIC(4,ACTPTR,0),"^")
- DO ^DIR
- KILL DIR
- +13 IF 'Y
- DO CLEAR^ABPACLG1
- KILL ABPACHK
- DO HEAD^ABPACLG1
- GOTO GETCHK^ABPACLG1
- +14 SET ABPA("TO")=+Y
- IF ACTPTR=ABPA("TO")
- Begin DoDot:1
- +15 WRITE *7,!?5,"<<< CANNOT TRANSFER TO THE SAME FACILITY >>>"
- HANG 3
- +16 DO CLEAR^ABPACLG1
- KILL ABPACHK
- DO HEAD^ABPACLG1
- End DoDot:1
- GOTO GETCHK^ABPACLG1
- +17 DO HEAD^ABPACLG1
- SET DX=0
- SET DY=12
- XECUTE XY
- DO EOP^ABPAMAIN
- +18 WRITE !?30,"Transfer Summary",!
- +19 WRITE !?3,"$",$JUSTIFY(ABPA("AMT"),9,2)," of check #",ABPACHK("NUM")
- +20 WRITE " from ",ABPAINS,!?3,"is to be transferred to "
- +21 WRITE $PIECE(^DIC(4,ABPA("TO"),0),"^")
- +22 SET DIR(0)="Y"
- SET DIR("A")="Is this correct"
- WRITE !
- DO ^DIR
- KILL DIR
- +23 IF 'Y
- DO CLEAR^ABPACLG1
- KILL ABPACHK
- DO HEAD^ABPACLG1
- GOTO GETCHK^ABPACLG1
- +24 GOTO START^ABPACLG5
