ABPAOP3 ;POST FACILITY DATA TO AREA DATABASE;[ 05/31/91 4:23 PM ]
;;1.4;AO PVT-INS TRACKING;*0*;IHS-OKC/KJR;JULY 25, 1991
A0 W !,"NOT AN ENTRY POINT" Q
A16 ;ESTABLISH NEW PATIENT FOR PI
S P3=$P(^ABPVAO(0),"^",3)
F I=P3:1 S ABPVDFN=I Q:$D(^ABPVAO(I))=0
S $P(^ABPVAO(0),"^",3)=ABPVDFN
S $P(^ABPVAO(0),"^",4)=$P(^ABPVAO(0),"^",4)+1
S ^ABPVAO(ABPVDFN,0)=NAME_"^"_FACDFN_"^"_HRN
S ^ABPVAO("D",HRN,ABPVDFN)=""
S ^ABPVAO("G",FACDFN,HRN,ABPVDFN)=""
S ^ABPVAO("B",NAME,ABPVDFN)=""
S ^ABPVAO(ABPVDFN,1,0)="^9002270.21DI^0^0"
S NPCNT=NPCNT+1,ZPCNT=ZPCNT+1 I ZPCNT#20=0 D UPDATE^ABPAOP4
A16A I $D(^ABPAPOST(1,"F",LOCCD,"P",0))'=1 D
.S ^ABPAPOST(1,"F",LOCCD,"P",0)="^9002270.612PA^^0"
I $D(^ABPAPOST(1,"F",LOCCD,"P",ABPVDFN,0))'=1 D
.S ^ABPAPOST(1,"F",LOCCD,"P",ABPVDFN,0)=ABPVDFN
.S ^ABPAPOST(1,"F",LOCCD,"P","B",ABPVDFN,ABPVDFN)=""
.S $P(^ABPAPOST(1,"F",LOCCD,"P",0),"^",3)=ABPVDFN
.S NEWVAL=+$P(^ABPAPOST(1,"F",LOCCD,"P",0),"^",4)+1
.S $P(^ABPAPOST(1,"F",LOCCD,"P",0),"^",4)=NEWVAL
A17 ;ESTABLISH NEW CLAIM RECORD FOR PATIENT
S P3=$P(^ABPVAO(ABPVDFN,1,0),"^",3)
F I=P3:1 S ABPV2DFN=I Q:'$D(^ABPVAO(ABPVDFN,1,I))
S $P(^ABPVAO(ABPVDFN,1,0),"^",3)=ABPV2DFN
S $P(^ABPVAO(ABPVDFN,1,0),"^",4)=$P(^ABPVAO(ABPVDFN,1,0),"^",4)+1
A18 S $P(^ABPVAO(ABPVDFN,1,ABPV2DFN,0),"^",1)=$P(XX,"^",5)
S $P(^ABPVAO(ABPVDFN,1,ABPV2DFN,0),"^",8)=$P(XX,"^",11)
S $P(^ABPVAO(ABPVDFN,1,ABPV2DFN,0),"^",9)=$P(XX,"^",12)
S $P(^ABPVAO(ABPVDFN,1,ABPV2DFN,0),"^",2)=$P(XX,"^",20)
S $P(^ABPVAO(ABPVDFN,1,ABPV2DFN,0),"^",12)=$P(XX,"^",21)
S ^ABPVAO("AC",$P(XX,"^",21),ABPVDFN,ABPV2DFN)=""
I $P(XX,"^",23)]"" D
.S $P(^ABPVAO(ABPVDFN,0),"^",4)=$P(XX,"^",23)
.S ^ABPVAO("F",$P(XX,"^",23),ABPVDFN)=""
S $P(^ABPVAO(ABPVDFN,1,ABPV2DFN,0),"^",6)=INSDFN
F I=1:1:2 S $P(^ABPVAO(ABPVDFN,1,ABPV2DFN,0),"^",I+3)=$P(XX,"^",I+5)
S $P(^ABPVAO(ABPVDFN,1,ABPV2DFN,0),"^",7)=$P(XX,"^",8)
S $P(^ABPVAO(ABPVDFN,1,ABPV2DFN,0),"^",11)=$P(XX,"^",10)
S ^ABPVAO("H",$P(XX,"^",10),ABPVDFN,ABPV2DFN)=""
S $P(^ABPVAO(ABPVDFN,1,ABPV2DFN,0),"^",17)="O"
S ^ABPVAO("CS","O",ABPVDFN,ABPV2DFN)=""
S DOS=$P(^ABPVAO(ABPVDFN,1,ABPV2DFN,0),"^",1) I DOS>0 D
.S ^ABPVAO("C",DOS,ABPVDFN,ABPV2DFN)=""
.S ^ABPVAO("PC",ABPVDFN,DOS,ABPV2DFN)=""
S ^ABPVAO("CN",$P(XX,"^",20),FACDFN,ABPVDFN,ABPV2DFN)=""
S ^ABPVAO("I",$P(XX,"^",20),ABPVDFN,ABPV2DFN)=""
S NCCNT=NCCNT+1,ZCCNT=ZCCNT+1 I ZCCNT#20=0 D UPDATE^ABPAOP4
G A7^ABPAOP0
ABPAOP3 ;POST FACILITY DATA TO AREA DATABASE;[ 05/31/91 4:23 PM ]
+1 ;;1.4;AO PVT-INS TRACKING;*0*;IHS-OKC/KJR;JULY 25, 1991
A0 WRITE !,"NOT AN ENTRY POINT"
QUIT
A16 ;ESTABLISH NEW PATIENT FOR PI
+1 SET P3=$PIECE(^ABPVAO(0),"^",3)
+2 FOR I=P3:1
SET ABPVDFN=I
IF $DATA(^ABPVAO(I))=0
QUIT
+3 SET $PIECE(^ABPVAO(0),"^",3)=ABPVDFN
+4 SET $PIECE(^ABPVAO(0),"^",4)=$PIECE(^ABPVAO(0),"^",4)+1
+5 SET ^ABPVAO(ABPVDFN,0)=NAME_"^"_FACDFN_"^"_HRN
+6 SET ^ABPVAO("D",HRN,ABPVDFN)=""
+7 SET ^ABPVAO("G",FACDFN,HRN,ABPVDFN)=""
+8 SET ^ABPVAO("B",NAME,ABPVDFN)=""
+9 SET ^ABPVAO(ABPVDFN,1,0)="^9002270.21DI^0^0"
+10 SET NPCNT=NPCNT+1
SET ZPCNT=ZPCNT+1
IF ZPCNT#20=0
DO UPDATE^ABPAOP4
A16A IF $DATA(^ABPAPOST(1,"F",LOCCD,"P",0))'=1
Begin DoDot:1
+1 SET ^ABPAPOST(1,"F",LOCCD,"P",0)="^9002270.612PA^^0"
End DoDot:1
+2 IF $DATA(^ABPAPOST(1,"F",LOCCD,"P",ABPVDFN,0))'=1
Begin DoDot:1
+3 SET ^ABPAPOST(1,"F",LOCCD,"P",ABPVDFN,0)=ABPVDFN
+4 SET ^ABPAPOST(1,"F",LOCCD,"P","B",ABPVDFN,ABPVDFN)=""
+5 SET $PIECE(^ABPAPOST(1,"F",LOCCD,"P",0),"^",3)=ABPVDFN
+6 SET NEWVAL=+$PIECE(^ABPAPOST(1,"F",LOCCD,"P",0),"^",4)+1
+7 SET $PIECE(^ABPAPOST(1,"F",LOCCD,"P",0),"^",4)=NEWVAL
End DoDot:1
A17 ;ESTABLISH NEW CLAIM RECORD FOR PATIENT
+1 SET P3=$PIECE(^ABPVAO(ABPVDFN,1,0),"^",3)
+2 FOR I=P3:1
SET ABPV2DFN=I
IF '$DATA(^ABPVAO(ABPVDFN,1,I))
QUIT
+3 SET $PIECE(^ABPVAO(ABPVDFN,1,0),"^",3)=ABPV2DFN
+4 SET $PIECE(^ABPVAO(ABPVDFN,1,0),"^",4)=$PIECE(^ABPVAO(ABPVDFN,1,0),"^",4)+1
A18 SET $PIECE(^ABPVAO(ABPVDFN,1,ABPV2DFN,0),"^",1)=$PIECE(XX,"^",5)
+1 SET $PIECE(^ABPVAO(ABPVDFN,1,ABPV2DFN,0),"^",8)=$PIECE(XX,"^",11)
+2 SET $PIECE(^ABPVAO(ABPVDFN,1,ABPV2DFN,0),"^",9)=$PIECE(XX,"^",12)
+3 SET $PIECE(^ABPVAO(ABPVDFN,1,ABPV2DFN,0),"^",2)=$PIECE(XX,"^",20)
+4 SET $PIECE(^ABPVAO(ABPVDFN,1,ABPV2DFN,0),"^",12)=$PIECE(XX,"^",21)
+5 SET ^ABPVAO("AC",$PIECE(XX,"^",21),ABPVDFN,ABPV2DFN)=""
+6 IF $PIECE(XX,"^",23)]""
Begin DoDot:1
+7 SET $PIECE(^ABPVAO(ABPVDFN,0),"^",4)=$PIECE(XX,"^",23)
+8 SET ^ABPVAO("F",$PIECE(XX,"^",23),ABPVDFN)=""
End DoDot:1
+9 SET $PIECE(^ABPVAO(ABPVDFN,1,ABPV2DFN,0),"^",6)=INSDFN
+10 FOR I=1:1:2
SET $PIECE(^ABPVAO(ABPVDFN,1,ABPV2DFN,0),"^",I+3)=$PIECE(XX,"^",I+5)
+11 SET $PIECE(^ABPVAO(ABPVDFN,1,ABPV2DFN,0),"^",7)=$PIECE(XX,"^",8)
+12 SET $PIECE(^ABPVAO(ABPVDFN,1,ABPV2DFN,0),"^",11)=$PIECE(XX,"^",10)
+13 SET ^ABPVAO("H",$PIECE(XX,"^",10),ABPVDFN,ABPV2DFN)=""
+14 SET $PIECE(^ABPVAO(ABPVDFN,1,ABPV2DFN,0),"^",17)="O"
+15 SET ^ABPVAO("CS","O",ABPVDFN,ABPV2DFN)=""
+16 SET DOS=$PIECE(^ABPVAO(ABPVDFN,1,ABPV2DFN,0),"^",1)
IF DOS>0
Begin DoDot:1
+17 SET ^ABPVAO("C",DOS,ABPVDFN,ABPV2DFN)=""
+18 SET ^ABPVAO("PC",ABPVDFN,DOS,ABPV2DFN)=""
End DoDot:1
+19 SET ^ABPVAO("CN",$PIECE(XX,"^",20),FACDFN,ABPVDFN,ABPV2DFN)=""
+20 SET ^ABPVAO("I",$PIECE(XX,"^",20),ABPVDFN,ABPV2DFN)=""
+21 SET NCCNT=NCCNT+1
SET ZCCNT=ZCCNT+1
IF ZCCNT#20=0
DO UPDATE^ABPAOP4
+22 GOTO A7^ABPAOP0
