ABPAOP0 ;POST FACILITY DATA TO AREA DATABASE;[ 05/28/91 4:27 PM ]
;;1.4;AO PVT-INS TRACKING;*0*;IHS-OKC/KJR;JULY 25, 1991
A0 K ABPA("HD") D:$D(ABPATLE)'=1 ^ABPAVAR S ABPA("HD",1)=ABPATLE
S ABPA("HD",2)="POST FACILITY DATA TO AREA DATABASE" D ^ABPAHD W !!
A0A L (^ABPVAO,^AUTNINS,^ABPAMLBL,^ABPAPOST):1
I '$T D H 3 L G XIT^ABPAOP4
.W *7,!!,?7,"Unable to Gain Exclusive control of necessary files."
.W !,?25,"THIS JOB HAS BEEN TERMINATED"
A0B S %ZIS("A")="Select Output device for the POSTING LOG: ",%IS="NP"
D ^%ZIS I +IO=0 D G XIT^ABPAOP4
.W !!?10,*7,"<<< INVALID DEVICE SELECTION - JOB ABORTED >>>" H 3
S ABPA("IO")=+IO D CURRENT^%ZIS
A1 S (R,RCT,RR)=0,ZPCNT=0,ZVCNT=0,ZCCNT=0 D WAIT^ABPAOP4,DT^DICRW
S R="",PGNO=0,LOC=0 K ABPAMLBL
K DIK,DA S DIK="^ABPAPOST(",DA=1 D ^DIK
A5 S LOC=$O(^ABPVGLOB(LOC)) I +LOC=0 D ZEND^ABPAOP4 G A1^ABPAOP5
S R="",NPCNT=0,NVCNT=0,NCCNT=0
A7 S R=$O(^ABPVGLOB(LOC,R)) G AZEND^ABPAOP4:R=""
S XX=^ABPVGLOB(LOC,R) I R>0 I $P(XX,"^")'="ABP1" G A7
;I R>0 I $P(XX,"^",22)'="P" G A7
I R>0 G A9
S FACNAME=$P(XX,"^",5)
I '$D(^ABPVGLOB(LOC,0)) D G XIT^ABPAOP4
.W !!,*7,"ZEROTH NODE NOT DEFINED FOR ",FACNAME," -- POSTING ABORTED"
S XX=^ABPVGLOB(LOC,0)
A9 S X=$S(R>0:$P(XX,"^",3),1:LOC),DIC="^AUTTLOC(",DIC(0)="",D="C"
D IX^DIC I +Y<0 S D="CTOO" D IX^DIC
I +Y<0 D G XIT^ABPAOP4
.W !!,*7,"FACILITY CODE LOOKUP ERROR ON CODE ",X
.W " -- POSTING ABORTED"
S LOCCD=+Y I R'>0 D G A7
A9A .I $D(^ABPAPOST(1,0))'=1 D
..S ^ABPAPOST(1,0)=DT,ABPAPOST("B",DT,1)=""
..S $P(^ABPAPOST(0),"^",3)=1
..S $P(^ABPAPOST(0),"^",4)=1
A9F .I $D(^ABPAPOST(1,"F",0))'=1 D
..S ^ABPAPOST(1,"F",0)="^9002270.61PA^^0"
.I $D(^ABPAPOST(1,"F",LOCCD,0))'=1 D
..S DATA=LOCCD_U_$P(XX,U,6)_U_$P(XX,U)_U_$P(XX,U,2)_U_U_U
..S DATA=DATA_($P(XX,U,3)/2)
..S ^ABPAPOST(1,"F",LOCCD,0)=DATA
..S ^ABPAPOST(1,"F","B",LOCCD,LOCCD)=""
..S $P(^ABPAPOST(1,"F",0),"^",3)=LOCCD
..S $P(^ABPAPOST(1,"F",0),"^",4)=$P(^ABPAPOST(1,"F",0),"^",4)+1
A10 I $D(^ABPVAO("CN",$P(XX,"^",20),LOCCD))=10 D G A7
.W !,?10,"BILL ID ",$J($P(XX,"^",20),8)," ALREADY POSTED"
;
CONT G A11^ABPAOP1
ABPAOP0 ;POST FACILITY DATA TO AREA DATABASE;[ 05/28/91 4:27 PM ]
+1 ;;1.4;AO PVT-INS TRACKING;*0*;IHS-OKC/KJR;JULY 25, 1991
A0 KILL ABPA("HD")
IF $DATA(ABPATLE)'=1
DO ^ABPAVAR
SET ABPA("HD",1)=ABPATLE
+1 SET ABPA("HD",2)="POST FACILITY DATA TO AREA DATABASE"
DO ^ABPAHD
WRITE !!
A0A LOCK (^ABPVAO,^AUTNINS,^ABPAMLBL,^ABPAPOST):1
+1 IF '$TEST
Begin DoDot:1
+2 WRITE *7,!!,?7,"Unable to Gain Exclusive control of necessary files."
+3 WRITE !,?25,"THIS JOB HAS BEEN TERMINATED"
End DoDot:1
HANG 3
LOCK
GOTO XIT^ABPAOP4
A0B SET %ZIS("A")="Select Output device for the POSTING LOG: "
SET %IS="NP"
+1 DO ^%ZIS
IF +IO=0
Begin DoDot:1
+2 WRITE !!?10,*7,"<<< INVALID DEVICE SELECTION - JOB ABORTED >>>"
HANG 3
End DoDot:1
GOTO XIT^ABPAOP4
+3 SET ABPA("IO")=+IO
DO CURRENT^%ZIS
A1 SET (R,RCT,RR)=0
SET ZPCNT=0
SET ZVCNT=0
SET ZCCNT=0
DO WAIT^ABPAOP4
DO DT^DICRW
+1 SET R=""
SET PGNO=0
SET LOC=0
KILL ABPAMLBL
+2 KILL DIK,DA
SET DIK="^ABPAPOST("
SET DA=1
DO ^DIK
A5 SET LOC=$ORDER(^ABPVGLOB(LOC))
IF +LOC=0
DO ZEND^ABPAOP4
GOTO A1^ABPAOP5
+1 SET R=""
SET NPCNT=0
SET NVCNT=0
SET NCCNT=0
A7 SET R=$ORDER(^ABPVGLOB(LOC,R))
IF R=""
GOTO AZEND^ABPAOP4
+1 SET XX=^ABPVGLOB(LOC,R)
IF R>0
IF $PIECE(XX,"^")'="ABP1"
GOTO A7
+2 ;I R>0 I $P(XX,"^",22)'="P" G A7
+3 IF R>0
GOTO A9
+4 SET FACNAME=$PIECE(XX,"^",5)
+5 IF '$DATA(^ABPVGLOB(LOC,0))
Begin DoDot:1
+6 WRITE !!,*7,"ZEROTH NODE NOT DEFINED FOR ",FACNAME," -- POSTING ABORTED"
End DoDot:1
GOTO XIT^ABPAOP4
+7 SET XX=^ABPVGLOB(LOC,0)
A9 SET X=$SELECT(R>0:$PIECE(XX,"^",3),1:LOC)
SET DIC="^AUTTLOC("
SET DIC(0)=""
SET D="C"
+1 DO IX^DIC
IF +Y<0
SET D="CTOO"
DO IX^DIC
+2 IF +Y<0
Begin DoDot:1
+3 WRITE !!,*7,"FACILITY CODE LOOKUP ERROR ON CODE ",X
+4 WRITE " -- POSTING ABORTED"
End DoDot:1
GOTO XIT^ABPAOP4
+5 SET LOCCD=+Y
IF R'>0
Begin DoDot:1
A9A IF $DATA(^ABPAPOST(1,0))'=1
Begin DoDot:2
+1 SET ^ABPAPOST(1,0)=DT
SET ABPAPOST("B",DT,1)=""
+2 SET $PIECE(^ABPAPOST(0),"^",3)=1
+3 SET $PIECE(^ABPAPOST(0),"^",4)=1
End DoDot:2
A9F IF $DATA(^ABPAPOST(1,"F",0))'=1
Begin DoDot:2
+1 SET ^ABPAPOST(1,"F",0)="^9002270.61PA^^0"
End DoDot:2
+2 IF $DATA(^ABPAPOST(1,"F",LOCCD,0))'=1
Begin DoDot:2
+3 SET DATA=LOCCD_U_$PIECE(XX,U,6)_U_$PIECE(XX,U)_U_$PIECE(XX,U,2)_U_U_U
+4 SET DATA=DATA_($PIECE(XX,U,3)/2)
+5 SET ^ABPAPOST(1,"F",LOCCD,0)=DATA
+6 SET ^ABPAPOST(1,"F","B",LOCCD,LOCCD)=""
+7 SET $PIECE(^ABPAPOST(1,"F",0),"^",3)=LOCCD
+8 SET $PIECE(^ABPAPOST(1,"F",0),"^",4)=$PIECE(^ABPAPOST(1,"F",0),"^",4)+1
End DoDot:2
End DoDot:1
GOTO A7
A10 IF $DATA(^ABPVAO("CN",$PIECE(XX,"^",20),LOCCD))=10
Begin DoDot:1
+1 WRITE !,?10,"BILL ID ",$JUSTIFY($PIECE(XX,"^",20),8)," ALREADY POSTED"
End DoDot:1
GOTO A7
+2 ;
CONT GOTO A11^ABPAOP1
