- ABPAOP1 ;POST FACILITY DATA TO AREA DATABASE;[ 07/25/91 11:29 AM ]
- ;;1.4;AO PVT-INS TRACKING;*0*;IHS-OKC/KJR;JULY 25, 1991
- A0 Q ;;NOT AN ENTRY POINT
- ;--------------------------------------------------------------------
- A11 ;PROCEDURE TO PROCESS INSURER INFORMATION
- S R=$O(^ABPVGLOB(LOC,R))
- I +R=0 G GLOBERR
- S XXX=^ABPVGLOB(LOC,R)
- I $P(XXX,"^",1)'="ABP2" G GLOBERR
- S INSNAME=$P(XX,"^",13),INSZIP=$P(XX,"^",17)
- S FOUND=0 I $D(^AUTNINS("B",INSNAME))=10 D
- .S RR=0 F I=0:0 D Q:(+RR=0)!(FOUND)
- ..S RR=$O(^AUTNINS("B",INSNAME,RR)) Q:+RR=0
- ..Q:$D(^AUTNINS(+RR,0))'=1
- ..I INSZIP=$P(^AUTNINS(+RR,0),"^",5) S INSDFN=RR,FOUND=1
- I 'FOUND D
- .S P3=$P(^AUTNINS(0),"^",3)
- .F I=P3:1 S INSDFN=I Q:$D(^AUTNINS(I,0))'=1
- .S $P(^AUTNINS(0),"^",3)=INSDFN
- .S $P(^AUTNINS(0),"^",4)=$P(^AUTNINS(0),"^",4)+1
- .S $P(^AUTNINS(INSDFN,0),"^",1)=INSNAME
- .S $P(^AUTNINS(INSDFN,0),"^",5)=$P(XX,"^",17)
- .S NVCNT=NVCNT+1,ZVCNT=ZVCNT+1 I ZVCNT#20=0 D UPDATE^ABPAOP4
- .I $D(^ABPAPOST(1,"F",LOCCD,"I",0))'=1 D
- ..S ^ABPAPOST(1,"F",LOCCD,"I",0)="^9002270.611PA^^0"
- .I $D(^ABPAPOST(1,"F",LOCCD,"I",INSDFN,0))'=1 D
- ..S ^ABPAPOST(1,"F",LOCCD,"I",INSDFN,0)=INSDFN
- ..S ^ABPAPOST(1,"F",LOCCD,"I","B",INSDFN,INSDFN)=""
- ..S $P(^ABPAPOST(1,"F",LOCCD,"I",0),"^",3)=INSDFN
- ..S NEWVAL=+$P(^ABPAPOST(1,"F",LOCCD,"I",0),"^",4)+1
- ..S $P(^ABPAPOST(1,"F",LOCCD,"I",0),"^",4)=NEWVAL
- F I=1,2,3,5 S $P(^AUTNINS(INSDFN,0),"^",I+1)=$P(XX,"^",I+13)
- S $P(^AUTNINS(INSDFN,0),"^",9)=$P(XX,"^",19)
- I $P(XXX,"^",6)'="" D
- .F I=2:1:6 S $P(^AUTNINS(INSDFN,1),"^",I-1)=$P(XXX,"^",I)
- K DIK,DA S DIK="^AUTNINS(",DA=INSDFN D IX1^DIK
- ;--------------------------------------------------------------------
- D A1^ABPAOP2 ;;SET INSURER MAILING LABEL FILE ENTRY
- A15 ;CHECK LAST NAME AND FIRST INITIAL
- S NAME=$P(XX,"^",2),LNAME=$P(NAME,",",1),FINIT=$E($P(NAME,",",2),1,1)
- S FAC=$P(XX,"^",3),FACDFN=0,FACDFN=$O(^AUTTLOC("C",FAC,FACDFN))
- I +FACDFN<1 W !,?10,"INVALID LOCATION CODE IN RECORD # ",R
- S HRN=$P(XX,"^",4)
- S ABPVDFN=0,ABPVDFN=$O(^ABPVAO("G",FACDFN,HRN,ABPVDFN))
- I ABPVDFN<1 G A16^ABPAOP3
- S ZNAME=$P(^ABPVAO(ABPVDFN,0),"^",1),ZLNAME=$P(ZNAME,",",1),ZFINIT=$E($P(ZNAME,",",2),1,1)
- I (ZLNAME'=LNAME)!(ZFINIT'=FINIT) G A15B
- G A17^ABPAOP3
- A15B G A17^ABPAOP3 ;; !,?5,"LAST NAME & FIRST INITIAL OF THIS FAC & CHART # DON'T MATCH",!,?7,"FACILITY NAME =",?25,NAME,!,?7,"AREA NAME = ",?25,ZNAME,!,?20,"NAME INFORMATION NOT UPDATED AT AREA" G A17^ABPAOP3
- GLOBERR U IO(0) W *7,!!,"--- ERROR DETECTED IN GLOBAL ""^ABPVGLOB"" ---"
- G XIT^ABPAOP4
- ABPAOP1 ;POST FACILITY DATA TO AREA DATABASE;[ 07/25/91 11:29 AM ]
- +1 ;;1.4;AO PVT-INS TRACKING;*0*;IHS-OKC/KJR;JULY 25, 1991
- A0 ;;NOT AN ENTRY POINT
- QUIT
- +1 ;--------------------------------------------------------------------
- A11 ;PROCEDURE TO PROCESS INSURER INFORMATION
- +1 SET R=$ORDER(^ABPVGLOB(LOC,R))
- +2 IF +R=0
- GOTO GLOBERR
- +3 SET XXX=^ABPVGLOB(LOC,R)
- +4 IF $PIECE(XXX,"^",1)'="ABP2"
- GOTO GLOBERR
- +5 SET INSNAME=$PIECE(XX,"^",13)
- SET INSZIP=$PIECE(XX,"^",17)
- +6 SET FOUND=0
- IF $DATA(^AUTNINS("B",INSNAME))=10
- Begin DoDot:1
- +7 SET RR=0
- FOR I=0:0
- Begin DoDot:2
- +8 SET RR=$ORDER(^AUTNINS("B",INSNAME,RR))
- IF +RR=0
- QUIT
- +9 IF $DATA(^AUTNINS(+RR,0))'=1
- QUIT
- +10 IF INSZIP=$PIECE(^AUTNINS(+RR,0),"^",5)
- SET INSDFN=RR
- SET FOUND=1
- End DoDot:2
- IF (+RR=0)!(FOUND)
- QUIT
- End DoDot:1
- +11 IF 'FOUND
- Begin DoDot:1
- +12 SET P3=$PIECE(^AUTNINS(0),"^",3)
- +13 FOR I=P3:1
- SET INSDFN=I
- IF $DATA(^AUTNINS(I,0))'=1
- QUIT
- +14 SET $PIECE(^AUTNINS(0),"^",3)=INSDFN
- +15 SET $PIECE(^AUTNINS(0),"^",4)=$PIECE(^AUTNINS(0),"^",4)+1
- +16 SET $PIECE(^AUTNINS(INSDFN,0),"^",1)=INSNAME
- +17 SET $PIECE(^AUTNINS(INSDFN,0),"^",5)=$PIECE(XX,"^",17)
- +18 SET NVCNT=NVCNT+1
- SET ZVCNT=ZVCNT+1
- IF ZVCNT#20=0
- DO UPDATE^ABPAOP4
- +19 IF $DATA(^ABPAPOST(1,"F",LOCCD,"I",0))'=1
- Begin DoDot:2
- +20 SET ^ABPAPOST(1,"F",LOCCD,"I",0)="^9002270.611PA^^0"
- End DoDot:2
- +21 IF $DATA(^ABPAPOST(1,"F",LOCCD,"I",INSDFN,0))'=1
- Begin DoDot:2
- +22 SET ^ABPAPOST(1,"F",LOCCD,"I",INSDFN,0)=INSDFN
- +23 SET ^ABPAPOST(1,"F",LOCCD,"I","B",INSDFN,INSDFN)=""
- +24 SET $PIECE(^ABPAPOST(1,"F",LOCCD,"I",0),"^",3)=INSDFN
- +25 SET NEWVAL=+$PIECE(^ABPAPOST(1,"F",LOCCD,"I",0),"^",4)+1
- +26 SET $PIECE(^ABPAPOST(1,"F",LOCCD,"I",0),"^",4)=NEWVAL
- End DoDot:2
- End DoDot:1
- +27 FOR I=1,2,3,5
- SET $PIECE(^AUTNINS(INSDFN,0),"^",I+1)=$PIECE(XX,"^",I+13)
- +28 SET $PIECE(^AUTNINS(INSDFN,0),"^",9)=$PIECE(XX,"^",19)
- +29 IF $PIECE(XXX,"^",6)'=""
- Begin DoDot:1
- +30 FOR I=2:1:6
- SET $PIECE(^AUTNINS(INSDFN,1),"^",I-1)=$PIECE(XXX,"^",I)
- End DoDot:1
- +31 KILL DIK,DA
- SET DIK="^AUTNINS("
- SET DA=INSDFN
- DO IX1^DIK
- +32 ;--------------------------------------------------------------------
- +33 ;;SET INSURER MAILING LABEL FILE ENTRY
- DO A1^ABPAOP2
- A15 ;CHECK LAST NAME AND FIRST INITIAL
- +1 SET NAME=$PIECE(XX,"^",2)
- SET LNAME=$PIECE(NAME,",",1)
- SET FINIT=$EXTRACT($PIECE(NAME,",",2),1,1)
- +2 SET FAC=$PIECE(XX,"^",3)
- SET FACDFN=0
- SET FACDFN=$ORDER(^AUTTLOC("C",FAC,FACDFN))
- +3 IF +FACDFN<1
- WRITE !,?10,"INVALID LOCATION CODE IN RECORD # ",R
- +4 SET HRN=$PIECE(XX,"^",4)
- +5 SET ABPVDFN=0
- SET ABPVDFN=$ORDER(^ABPVAO("G",FACDFN,HRN,ABPVDFN))
- +6 IF ABPVDFN<1
- GOTO A16^ABPAOP3
- +7 SET ZNAME=$PIECE(^ABPVAO(ABPVDFN,0),"^",1)
- SET ZLNAME=$PIECE(ZNAME,",",1)
- SET ZFINIT=$EXTRACT($PIECE(ZNAME,",",2),1,1)
- +8 IF (ZLNAME'=LNAME)!(ZFINIT'=FINIT)
- GOTO A15B
- +9 GOTO A17^ABPAOP3
- A15B ;; !,?5,"LAST NAME & FIRST INITIAL OF THIS FAC & CHART # DON'T MATCH",!,?7,"FACILITY NAME =",?25,NAME,!,?7,"AREA NAME = ",?25,ZNAME,!,?20,"NAME INFORMATION NOT UPDATED AT AREA" G A17^ABPAOP3
- GOTO A17^ABPAOP3
- GLOBERR USE IO(0)
- WRITE *7,!!,"--- ERROR DETECTED IN GLOBAL ""^ABPVGLOB"" ---"
- +1 GOTO XIT^ABPAOP4
