- 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
