- 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
