- ABPACLG5 ;CHECK LOG UTILITY FUNCTIONS - PART 4; [ 06/26/91 9:48 PM ]
- ;;1.4;AO PVT-INS TRACKING;*0*;IHS-OKC/KJR;JULY 25, 1991
- Q ;;NOT AN ENTRY POINT
- START W ! D WAIT^DICD
- ;--------------------------------------------------------------
- ;PROCEDURE TO MODIFY THE CURRENT CHECK ENTRY
- K DIR,DIC,DIE,DA,DR
- S DA(2)=ABPADFN(1),DA(1)=ABPADFN(2),DA=ABPADFN(3)
- S DIE="^ABPACHKS("_DA(2)_",""I"","_DA(1)_",""C"","
- S Y(0)=^ABPACHKS(DA(2),"I",DA(1),"C",DA,0)
- S RBAL=$P(Y(0),"^",9)-ABPA("AMT")
- S DR="4///"_DUZ_";5///NOW;8///"_RBAL D ^DIE
- I RBAL=0 K ^ABPACHKS("RB",DA(2),DA(1),DA),RBAL
- 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///"_ABPA("AMT")_";4"
- W ! D ^DIE W ! D WAIT^DICD
- ;--------------------------------------------------------------------
- ;PROCEDURE TO SET UP THE TRANSFERED CHECK ENTRY
- K DIC,DIK,DIE,DA,DR
- S DIC="^ABPACHKS(",DIC(0)="L",X=$P(^DIC(4,ABPA("TO"),0),"^") D ^DIC
- S DA(1)=+Y,X=+^ABPACHKS(ABPADFN(1),"I",ABPADFN(2),0)
- I $D(^ABPACHKS(DA(1),"I","B",X))=10 D
- .S DA(2)=DA(1),DA(1)="",DA(1)=$O(^ABPACHKS(DA(2),"I","B",X,DA(1)))
- I $D(DA(2))=0 D
- .S ABPAP3=+$P(^ABPACHKS(DA(1),"I",0),"^",3)+1
- .S ABPAP4=+$P(^ABPACHKS(DA(1),"I",0),"^",4)+1
- .F DA=ABPAP3:1 Q:$D(^ABPACHKS(DA(1),"I",DA,0))'=1
- .S ^ABPACHKS(DA(1),"I",DA,0)=X
- .S $P(^ABPACHKS(DA(1),"I",0),"^",3)=DA
- .S $P(^ABPACHKS(DA(1),"I",0),"^",4)=ABPAP4 K ABPAP3,ABPAP4
- .K DIK S DIK="^ABPACHKS("_DA(1)_",""I""," D IX1^DIK
- .I $D(^ABPACHKS(DA(1),"I",DA,"C",0))'=1 D
- ..S ^ABPACHKS(DA(1),"I",DA,"C",0)="^9002270.311AI^^0"
- .S DAH1=DA(1),DAH=DA K DA S DA(2)=DAH1,DA(1)=DAH K DAH1,DAH
- K DIC,DIK,DIE,DR
- S DIC="^ABPACHKS("_DA(2)_",""I"","_DA(1)_",""C"",",DIC(0)="LZ"
- S X=ABPACHK("NUM") D ^DIC S DA=+Y
- K DIE,DR S DIE="^ABPACHKS("_DA(2)_",""I"","_DA(1)_",""C"","
- G START^ABPACLG6
- ABPACLG5 ;CHECK LOG UTILITY FUNCTIONS - PART 4; [ 06/26/91 9:48 PM ]
- +1 ;;1.4;AO PVT-INS TRACKING;*0*;IHS-OKC/KJR;JULY 25, 1991
- +2 ;;NOT AN ENTRY POINT
- QUIT
- START WRITE !
- DO WAIT^DICD
- +1 ;--------------------------------------------------------------
- +2 ;PROCEDURE TO MODIFY THE CURRENT CHECK ENTRY
- +3 KILL DIR,DIC,DIE,DA,DR
- +4 SET DA(2)=ABPADFN(1)
- SET DA(1)=ABPADFN(2)
- SET DA=ABPADFN(3)
- +5 SET DIE="^ABPACHKS("_DA(2)_",""I"","_DA(1)_",""C"","
- +6 SET Y(0)=^ABPACHKS(DA(2),"I",DA(1),"C",DA,0)
- +7 SET RBAL=$PIECE(Y(0),"^",9)-ABPA("AMT")
- +8 SET DR="4///"_DUZ_";5///NOW;8///"_RBAL
- DO ^DIE
- +9 IF RBAL=0
- KILL ^ABPACHKS("RB",DA(2),DA(1),DA),RBAL
- +10 IF $DATA(^ABPACHKS(DA(2),"I",DA(1),"C",DA,"SP",0))'=1
- Begin DoDot:1
- +11 SET ^ABPACHKS(DA(2),"I",DA(1),"C",DA,"SP",0)="^9002270.31113DA^^0"
- End DoDot:1
- +12 SET %DT="T"
- SET X="NOW"
- DO ^%DT
- KILL DIC,DIE,DR
- +13 SET DIC="^ABPACHKS("_DA(2)_",""I"","_DA(1)_",""C"","_DA_",""SP"","
- +14 KILL DA
- SET DA(3)=ABPADFN(1)
- SET DA(2)=ABPADFN(2)
- SET DA(1)=ABPADFN(3)
- +15 SET DIC(0)="LZ"
- SET X=Y
- DO ^DIC
- SET ABPADFN(4)=+Y
- KILL DIC,DIE,DA,DR
- +16 SET DA(3)=ABPADFN(1)
- SET DA(2)=ABPADFN(2)
- SET DA(1)=ABPADFN(3)
- SET DA=ABPADFN(4)
- +17 SET DIE="^ABPACHKS("_DA(3)_",""I"","_DA(2)_",""C"","_DA(1)_",""SP"","
- +18 SET DR="1///"_ABPA("FUNC")_";2///"_DUZ_";3///"_ABPA("AMT")_";4"
- +19 WRITE !
- DO ^DIE
- WRITE !
- DO WAIT^DICD
- +20 ;--------------------------------------------------------------------
- +21 ;PROCEDURE TO SET UP THE TRANSFERED CHECK ENTRY
- +22 KILL DIC,DIK,DIE,DA,DR
- +23 SET DIC="^ABPACHKS("
- SET DIC(0)="L"
- SET X=$PIECE(^DIC(4,ABPA("TO"),0),"^")
- DO ^DIC
- +24 SET DA(1)=+Y
- SET X=+^ABPACHKS(ABPADFN(1),"I",ABPADFN(2),0)
- +25 IF $DATA(^ABPACHKS(DA(1),"I","B",X))=10
- Begin DoDot:1
- +26 SET DA(2)=DA(1)
- SET DA(1)=""
- SET DA(1)=$ORDER(^ABPACHKS(DA(2),"I","B",X,DA(1)))
- End DoDot:1
- +27 IF $DATA(DA(2))=0
- Begin DoDot:1
- +28 SET ABPAP3=+$PIECE(^ABPACHKS(DA(1),"I",0),"^",3)+1
- +29 SET ABPAP4=+$PIECE(^ABPACHKS(DA(1),"I",0),"^",4)+1
- +30 FOR DA=ABPAP3:1
- IF $DATA(^ABPACHKS(DA(1),"I",DA,0))'=1
- QUIT
- +31 SET ^ABPACHKS(DA(1),"I",DA,0)=X
- +32 SET $PIECE(^ABPACHKS(DA(1),"I",0),"^",3)=DA
- +33 SET $PIECE(^ABPACHKS(DA(1),"I",0),"^",4)=ABPAP4
- KILL ABPAP3,ABPAP4
- +34 KILL DIK
- SET DIK="^ABPACHKS("_DA(1)_",""I"","
- DO IX1^DIK
- +35 IF $DATA(^ABPACHKS(DA(1),"I",DA,"C",0))'=1
- Begin DoDot:2
- +36 SET ^ABPACHKS(DA(1),"I",DA,"C",0)="^9002270.311AI^^0"
- End DoDot:2
- +37 SET DAH1=DA(1)
- SET DAH=DA
- KILL DA
- SET DA(2)=DAH1
- SET DA(1)=DAH
- KILL DAH1,DAH
- End DoDot:1
- +38 KILL DIC,DIK,DIE,DR
- +39 SET DIC="^ABPACHKS("_DA(2)_",""I"","_DA(1)_",""C"","
- SET DIC(0)="LZ"
- +40 SET X=ABPACHK("NUM")
- DO ^DIC
- SET DA=+Y
- +41 KILL DIE,DR
- SET DIE="^ABPACHKS("_DA(2)_",""I"","_DA(1)_",""C"","
- +42 GOTO START^ABPACLG6
