- ABPAMLBL ;PRINT INSURER MAILING LABELS (BATCH); [ 07/03/91 7:50 PM ]
- ;;1.4;AO PVT-INS TRACKING;*0*;IHS-OKC/KJR;JULY 25, 1991
- A0 G ABORT
- ;
- A1 D DT^DICRW K ABPA("HD") S ABPA("HD",1)=ABPATLE
- S ABPA("HD",2)="PRINT Claim Mailing LABELS (batch)" D ^ABPAHD
- ;
- A2 K DIC,DIE,DA,DR S DIC="^ABPAMLBL(",DIC(0)="AEQZ"
- S DIC("A")="Select MAILING LABEL POSTING PERIOD // " W !!! D ^DIC
- G:+Y<0 END S ABPADFN=+Y,ABPAMLDT=Y(0,0)
- ;
- A3 K DIC,DIE,DA,DR S DIC="^DIC(4,",DIC(0)="AEQZ"
- S DIC("A")="Select MAILING LABEL FACILITY // " W ! D ^DIC
- G:+Y<0 A2 S LOCCD=+Y
- I $D(^ABPAMLBL(ABPADFN,"L",LOCCD,0))'=1 D G A3
- .W !,*7,!?3,"<<< NO LABELS FOUND FOR '",Y(0,0)
- .W "' DURING ",ABPAMLDT," >>>"
- ;
- A4 S %ZIS("A")="Select LABEL PRINTER DEVICE: ",%IS="P" W ! D ^%ZIS
- I $D(IO("S"))=1 X ^%ZIS(2,IO("S"),11)
- K %ZIS("A"),%IS G:+IO=0 A3
- U IO(0) W !!,"Please make sure labels have been put into the printer."
- U IO(0) W !,"Press [RETURN] when you are ready... " R X:DTIME
- G:'$T A6 U IO(0) W !!
- ;
- A5 S FLBL="" S RR=0 F I=1:1 D Q:RR=""
- .K NAME,ADDR,CITY,STATE,ZIP,DATA
- .S RR=$O(^ABPAMLBL(ABPADFN,"L",LOCCD,"I","AC",RR)) Q:RR="" S R=0
- .S R=$O(^ABPAMLBL(ABPADFN,"L",LOCCD,"I","AC",RR,R)) Q:+R=0
- .Q:$D(^ABPAMLBL(ABPADFN,"L",LOCCD,"I",R,0))'=1
- .Q:$D(^AUTNINS(R,0))'=1
- .S NAME=$P(^AUTNINS(R,0),"^")
- .I $D(^AUTNINS(R,1))=1 I $L($P(^AUTNINS(R,1),"^"))>3 D
- ..S DATA=^AUTNINS(R,1)
- .I $D(^AUTNINS(R,1))=1 I $L($P(^AUTNINS(R,1),"^"))'>3 D
- ..S DATA=^AUTNINS(R,0)
- .I $D(^AUTNINS(R,1))'=1 S DATA=^AUTNINS(R,0)
- .S NAME(1)=$P(DATA,"^"),ADDR=$P(DATA,"^",2),CITY=$P(DATA,"^",3)
- .S STATE="",PTR=$P(DATA,"^",4)
- .I +PTR>0 I $D(^DIC(5,PTR,0))=1 D
- ..S STATE=$P(^DIC(5,PTR,0),"^",2)
- .S ZIP=$P(DATA,"^",5)
- .S:NAME(1)'=NAME NAME=NAME(1) K NAME(1)
- .I $D(FLBL)=1 D
- ..F J=0:0 D Q:$D(FLBL)'=1
- ...I $D(IO("S"))=1 X ^%ZIS(2,IO("S"),10) H 2
- ...F K=1:1:2 D
- ....U IO W NAME
- ....U IO W !,ADDR,!,CITY,", ",STATE," ",ZIP
- ....U IO W !!!!
- ...H 2 I $D(IO("S"))=1 X ^%ZIS(2,IO("S"),11) H 2
- ...U IO(0) W !!,"ARE YOUR LABELS LINED UP" S %=2 D YN^DICN
- ...U IO(0) W !!
- ...I +%'=1 D
- ....U IO(0) W "Please adjust...press [RETURN] when ready"
- ....U IO(0) R X:DTIME U IO(0) W !!
- ...I +%=1 D
- ....K FLBL I $D(IO("S"))=1 X ^%ZIS(2,IO("S"),10) H 2
- .F J=1:1:2 D
- ..U IO W NAME,!,ADDR,!,CITY,", ",STATE," ",ZIP,!!!!
- .H 1
- ;
- A6 H 2 I $D(IO("S"))=1 X ^%ZIS(2,IO("S"),11)
- X ^%ZIS("C") K IOP,IO("S") U IO(0) W !!
- ;
- END K X,Y,DIC,DIE,DA,DR,NAME,ADDR,CITY,STATE,ZIP,FLBL,ABPADFN,LOCCD,DATA
- K ABPAMLDT,I,J,K
- Q
- ;
- ABORT W !!,"ACCESS DENIED!!!" Q
- ABPAMLBL ;PRINT INSURER MAILING LABELS (BATCH); [ 07/03/91 7:50 PM ]
- +1 ;;1.4;AO PVT-INS TRACKING;*0*;IHS-OKC/KJR;JULY 25, 1991
- A0 GOTO ABORT
- +1 ;
- A1 DO DT^DICRW
- KILL ABPA("HD")
- SET ABPA("HD",1)=ABPATLE
- +1 SET ABPA("HD",2)="PRINT Claim Mailing LABELS (batch)"
- DO ^ABPAHD
- +2 ;
- A2 KILL DIC,DIE,DA,DR
- SET DIC="^ABPAMLBL("
- SET DIC(0)="AEQZ"
- +1 SET DIC("A")="Select MAILING LABEL POSTING PERIOD // "
- WRITE !!!
- DO ^DIC
- +2 IF +Y<0
- GOTO END
- SET ABPADFN=+Y
- SET ABPAMLDT=Y(0,0)
- +3 ;
- A3 KILL DIC,DIE,DA,DR
- SET DIC="^DIC(4,"
- SET DIC(0)="AEQZ"
- +1 SET DIC("A")="Select MAILING LABEL FACILITY // "
- WRITE !
- DO ^DIC
- +2 IF +Y<0
- GOTO A2
- SET LOCCD=+Y
- +3 IF $DATA(^ABPAMLBL(ABPADFN,"L",LOCCD,0))'=1
- Begin DoDot:1
- +4 WRITE !,*7,!?3,"<<< NO LABELS FOUND FOR '",Y(0,0)
- +5 WRITE "' DURING ",ABPAMLDT," >>>"
- End DoDot:1
- GOTO A3
- +6 ;
- A4 SET %ZIS("A")="Select LABEL PRINTER DEVICE: "
- SET %IS="P"
- WRITE !
- DO ^%ZIS
- +1 IF $DATA(IO("S"))=1
- XECUTE ^%ZIS(2,IO("S"),11)
- +2 KILL %ZIS("A"),%IS
- IF +IO=0
- GOTO A3
- +3 USE IO(0)
- WRITE !!,"Please make sure labels have been put into the printer."
- +4 USE IO(0)
- WRITE !,"Press [RETURN] when you are ready... "
- READ X:DTIME
- +5 IF '$TEST
- GOTO A6
- USE IO(0)
- WRITE !!
- +6 ;
- A5 SET FLBL=""
- SET RR=0
- FOR I=1:1
- Begin DoDot:1
- +1 KILL NAME,ADDR,CITY,STATE,ZIP,DATA
- +2 SET RR=$ORDER(^ABPAMLBL(ABPADFN,"L",LOCCD,"I","AC",RR))
- IF RR=""
- QUIT
- SET R=0
- +3 SET R=$ORDER(^ABPAMLBL(ABPADFN,"L",LOCCD,"I","AC",RR,R))
- IF +R=0
- QUIT
- +4 IF $DATA(^ABPAMLBL(ABPADFN,"L",LOCCD,"I",R,0))'=1
- QUIT
- +5 IF $DATA(^AUTNINS(R,0))'=1
- QUIT
- +6 SET NAME=$PIECE(^AUTNINS(R,0),"^")
- +7 IF $DATA(^AUTNINS(R,1))=1
- IF $LENGTH($PIECE(^AUTNINS(R,1),"^"))>3
- Begin DoDot:2
- +8 SET DATA=^AUTNINS(R,1)
- End DoDot:2
- +9 IF $DATA(^AUTNINS(R,1))=1
- IF $LENGTH($PIECE(^AUTNINS(R,1),"^"))'>3
- Begin DoDot:2
- +10 SET DATA=^AUTNINS(R,0)
- End DoDot:2
- +11 IF $DATA(^AUTNINS(R,1))'=1
- SET DATA=^AUTNINS(R,0)
- +12 SET NAME(1)=$PIECE(DATA,"^")
- SET ADDR=$PIECE(DATA,"^",2)
- SET CITY=$PIECE(DATA,"^",3)
- +13 SET STATE=""
- SET PTR=$PIECE(DATA,"^",4)
- +14 IF +PTR>0
- IF $DATA(^DIC(5,PTR,0))=1
- Begin DoDot:2
- +15 SET STATE=$PIECE(^DIC(5,PTR,0),"^",2)
- End DoDot:2
- +16 SET ZIP=$PIECE(DATA,"^",5)
- +17 IF NAME(1)'=NAME
- SET NAME=NAME(1)
- KILL NAME(1)
- +18 IF $DATA(FLBL)=1
- Begin DoDot:2
- +19 FOR J=0:0
- Begin DoDot:3
- +20 IF $DATA(IO("S"))=1
- XECUTE ^%ZIS(2,IO("S"),10)
- HANG 2
- +21 FOR K=1:1:2
- Begin DoDot:4
- +22 USE IO
- WRITE NAME
- +23 USE IO
- WRITE !,ADDR,!,CITY,", ",STATE," ",ZIP
- +24 USE IO
- WRITE !!!!
- End DoDot:4
- +25 HANG 2
- IF $DATA(IO("S"))=1
- XECUTE ^%ZIS(2,IO("S"),11)
- HANG 2
- +26 USE IO(0)
- WRITE !!,"ARE YOUR LABELS LINED UP"
- SET %=2
- DO YN^DICN
- +27 USE IO(0)
- WRITE !!
- +28 IF +%'=1
- Begin DoDot:4
- +29 USE IO(0)
- WRITE "Please adjust...press [RETURN] when ready"
- +30 USE IO(0)
- READ X:DTIME
- USE IO(0)
- WRITE !!
- End DoDot:4
- +31 IF +%=1
- Begin DoDot:4
- +32 KILL FLBL
- IF $DATA(IO("S"))=1
- XECUTE ^%ZIS(2,IO("S"),10)
- HANG 2
- End DoDot:4
- End DoDot:3
- IF $DATA(FLBL)'=1
- QUIT
- End DoDot:2
- +33 FOR J=1:1:2
- Begin DoDot:2
- +34 USE IO
- WRITE NAME,!,ADDR,!,CITY,", ",STATE," ",ZIP,!!!!
- End DoDot:2
- +35 HANG 1
- End DoDot:1
- IF RR=""
- QUIT
- +36 ;
- A6 HANG 2
- IF $DATA(IO("S"))=1
- XECUTE ^%ZIS(2,IO("S"),11)
- +1 XECUTE ^%ZIS("C")
- KILL IOP,IO("S")
- USE IO(0)
- WRITE !!
- +2 ;
- END KILL X,Y,DIC,DIE,DA,DR,NAME,ADDR,CITY,STATE,ZIP,FLBL,ABPADFN,LOCCD,DATA
- +1 KILL ABPAMLDT,I,J,K
- +2 QUIT
- +3 ;
- ABORT WRITE !!,"ACCESS DENIED!!!"
- QUIT
