ACHSDNL1 ; IHS/ITSC/PMF - DENIAL LTR/FS (DRIVER) (2/6) ; [ 10/31/2003 11:44 AM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**4,6,22**;JUNE 11, 2001;Build 13
;ACHS*3.1*4 allow multiple office copies
;ACHS*3.1*6 6.5.03 IHS/SET/FCJ NO LONGER WANT MANDATORY OFFICE COPY
;
START ;ENTRY POINT - TaskMan. PRINT LETTERS AND FACT SHEETS.
S ACHSQUIT=0
D BRPT^ACHS
S ACHSBM=ACHSBM-4
W @IOF
I $G(ACHDBDT) S ACHDBDT=ACHDBDT-1
G:'ACHDBDT S3
S1 ;
I $G(ACHDBDT) S ACHDBDT=$O(^ACHSDEN(DUZ(2),"D","AISSUE",ACHDBDT)) G END:'ACHDBDT!(ACHDBDT>ACHDEDT)!($G(ACHSQUIT))
S ACHSA=0
S2 ;
S ACHSA=$O(^ACHSDEN(DUZ(2),"D","AISSUE",ACHDBDT,ACHSA))
G S1:+ACHSA=0
G S2:$$DN^ACHS(0,8)="Y"
G S2:$E($$DN^ACHS(0,1))="#"
;
S3 ;
S ACHDONE=""
;ACHS*3.1*4 4/5/02 pmf print 0 to 10 office copies
;D ^ACHSDNL2 Q:$G(ACHSQUIT) ; ACHS*3.1*4
;ACHS*3.1*6 6.5.03 IHS/SET/FCJ NO LONGER WANT MANDATORY OFFICE COPY
;S:'$G(ACHDCOFF) ACHDCOFF=1 ;ACHS*3.1*6 6.5.03
S:'$G(ACHDCOFF) ACHDCOFF=0 ;ACHS*3.1*6 6.5.03
F ACHSIII=1:1:ACHDCOFF D ^ACHSDNL2 Q:$G(ACHSQUIT) ; ACHS*3.1*4
I $G(ACHSQUIT) Q ; ACHS*3.1*4
S ACHDONE=1 ; ACHS*3.1*4
;
I $D(ACHDPROZ) S ACHDCPAT=0
I ACHDCPAT>0 F ACHD("I")=1:1:ACHDCPAT D ^ACHSDNL2,CKPTR G:X=27!(X=U) END
S ACHD("CPAT")=ACHDCPAT
G:ACHDCVEN'>0 PRNTFACT
K ACHDCPAT
I $D(ACHDPROZ) G PROZ
S ACHDNAME=$P($G(^ACHSDEN(DUZ(2),"D",ACHSA,100)),U,3)
S ACHDADDR=$P($G(^ACHSDEN(DUZ(2),"D",ACHSA,100)),U,4,7)
S ACHSVPTR=""
S ACHDONFL=$S($$DN^ACHS(100,1)="Y":1,1:0)
;
I ACHDONFL,$$DN^ACHS(100,2) D
.S ACHSVPTR=$$DN^ACHS(100,2)
.S ACHDNAME=$P($G(^AUTTVNDR(ACHSVPTR,0)),U)
;
F ACHD("I")=1:1:ACHDCVEN D ^ACHSDNL2,CKPTR G:X=27!(X=U) END
;
;FIND ALL 'OTHER PROVIDER ON-FILE' ENTRIES
S ACHDNAME="",ACHDONFL=1
F ACHDVEND=0:0 S ACHDVEND=$O(^ACHSDEN(DUZ(2),"D",ACHSA,200,ACHDVEND)) Q:'ACHDVEND D
.S ACHSVPTR=$P($G(^ACHSDEN(DUZ(2),"D",ACHSA,200,ACHDVEND,0)),U)
.S ACHDNAME=$P($G(^AUTTVNDR($P($G(^ACHSDEN(DUZ(2),"D",ACHSA,200,ACHDVEND,0)),U),0)),U) F ACHD("I")=1:1:ACHDCVEN D ^ACHSDNL2 Q:X=27!(X=U)
;
;FIND ALL 'OTHER PROVIDER (NOT ON-FILE)' ENTRIES
S ACHDONFL=0,ACHDNODE=210
F ACHDVEND=0:0 S ACHDVEND=$O(^ACHSDEN(DUZ(2),"D",ACHSA,210,ACHDVEND)) Q:'ACHDVEND D
.S ACHDNAME=$P($G(^ACHSDEN(DUZ(2),"D",ACHSA,210,ACHDVEND,0)),U)
.S ACHDADDR=$P($G(^ACHSDEN(DUZ(2),"D",ACHSA,210,ACHDVEND,0)),U,2,5)
.F ACHD("I")=1:1:ACHDCVEN D ^ACHSDNL2 Q:X=27!(X=U)
;
;
PRNTFACT ;
I ACHDCFAC F ACHD("I")=1:1:ACHDCFAC D ^ACHSDNL4,CKPTR G:X=27!(X=U) END
I ACHDBDT S ACHDCPAT=ACHD("CPAT") G S2
END ;
K A,ACHDADDR,ACHDOC,ACHDOS,ACHDCFAC,ACHDCPAT,ACHDCVEN,ACHSA,ACHDISDT,ACHDNAME,ACHDNODE,ACHDRQDT,ACHDST,ACHDVEND,ACHDONFL
D ERPT^ACHS,END^ACHSDNL
Q
;
CKPTR ; --- Check if user pressed ESC
I $D(ZTSK) S X=0 Q
U IO(0)
R *X:0
I X'=27,(X'=U) U IO Q
W *7,*7,*7
F R X:0 Q:'$T
W !!,"*** PRINTING INTERRUPTED ***",!
S X=27
Q
;
PROZ ;
I $P(ACHDPROZ,U,2)'="Y" G PROZ1
S ACHSVPTR=$P(ACHDPROZ,U,3)
S ACHDONFL=1
S ACHDNAME=$P($G(^AUTTVNDR(ACHSVPTR,0)),U)
D ^ACHSDNL2
G PRNTFACT
;
PROZ1 ;
I $P(ACHDPROZ,U,2)'="N" Q
S ACHDONFL=0,ACHDVEND=$P(ACHDPROZ,U,3)
I 'ACHDVEND S ACHDNAME=$P(ACHDPROZ,U),ACHDADDR=$P($G(^ACHSDEN(DUZ(2),"D",ACHSA,100)),U,3,7) G PROZ2
S ACHDNAME=$P($G(^ACHSDEN(DUZ(2),"D",ACHSA,210,ACHDVEND,0)),U)
;ACHS*3.1*22 ;CHANGED 3 TO 2 IN NXT LINE
S ACHDADDR=$P($G(^ACHSDEN(DUZ(2),"D",ACHSA,210,ACHDVEND,0)),U,2,7)
PROZ2 ;
F ACHD("I")=1:1:ACHDCVEN D ^ACHSDNL2
G PRNTFACT
;
ACHSDNL1 ; IHS/ITSC/PMF - DENIAL LTR/FS (DRIVER) (2/6) ; [ 10/31/2003 11:44 AM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**4,6,22**;JUNE 11, 2001;Build 13
+2 ;ACHS*3.1*4 allow multiple office copies
+3 ;ACHS*3.1*6 6.5.03 IHS/SET/FCJ NO LONGER WANT MANDATORY OFFICE COPY
+4 ;
START ;ENTRY POINT - TaskMan. PRINT LETTERS AND FACT SHEETS.
+1 SET ACHSQUIT=0
+2 DO BRPT^ACHS
+3 SET ACHSBM=ACHSBM-4
+4 WRITE @IOF
+5 IF $GET(ACHDBDT)
SET ACHDBDT=ACHDBDT-1
+6 IF 'ACHDBDT
GOTO S3
S1 ;
+1 IF $GET(ACHDBDT)
SET ACHDBDT=$ORDER(^ACHSDEN(DUZ(2),"D","AISSUE",ACHDBDT))
IF 'ACHDBDT!(ACHDBDT>ACHDEDT)!($GET(ACHSQUIT))
GOTO END
+2 SET ACHSA=0
S2 ;
+1 SET ACHSA=$ORDER(^ACHSDEN(DUZ(2),"D","AISSUE",ACHDBDT,ACHSA))
+2 IF +ACHSA=0
GOTO S1
+3 IF $$DN^ACHS(0,8)="Y"
GOTO S2
+4 IF $EXTRACT($$DN^ACHS(0,1))="#"
GOTO S2
+5 ;
S3 ;
+1 SET ACHDONE=""
+2 ;ACHS*3.1*4 4/5/02 pmf print 0 to 10 office copies
+3 ;D ^ACHSDNL2 Q:$G(ACHSQUIT) ; ACHS*3.1*4
+4 ;ACHS*3.1*6 6.5.03 IHS/SET/FCJ NO LONGER WANT MANDATORY OFFICE COPY
+5 ;S:'$G(ACHDCOFF) ACHDCOFF=1 ;ACHS*3.1*6 6.5.03
+6 ;ACHS*3.1*6 6.5.03
IF '$GET(ACHDCOFF)
SET ACHDCOFF=0
+7 ; ACHS*3.1*4
FOR ACHSIII=1:1:ACHDCOFF
DO ^ACHSDNL2
IF $GET(ACHSQUIT)
QUIT
+8 ; ACHS*3.1*4
IF $GET(ACHSQUIT)
QUIT
+9 ; ACHS*3.1*4
SET ACHDONE=1
+10 ;
+11 IF $DATA(ACHDPROZ)
SET ACHDCPAT=0
+12 IF ACHDCPAT>0
FOR ACHD("I")=1:1:ACHDCPAT
DO ^ACHSDNL2
DO CKPTR
IF X=27!(X=U)
GOTO END
+13 SET ACHD("CPAT")=ACHDCPAT
+14 IF ACHDCVEN'>0
GOTO PRNTFACT
+15 KILL ACHDCPAT
+16 IF $DATA(ACHDPROZ)
GOTO PROZ
+17 SET ACHDNAME=$PIECE($GET(^ACHSDEN(DUZ(2),"D",ACHSA,100)),U,3)
+18 SET ACHDADDR=$PIECE($GET(^ACHSDEN(DUZ(2),"D",ACHSA,100)),U,4,7)
+19 SET ACHSVPTR=""
+20 SET ACHDONFL=$SELECT($$DN^ACHS(100,1)="Y":1,1:0)
+21 ;
+22 IF ACHDONFL
IF $$DN^ACHS(100,2)
Begin DoDot:1
+23 SET ACHSVPTR=$$DN^ACHS(100,2)
+24 SET ACHDNAME=$PIECE($GET(^AUTTVNDR(ACHSVPTR,0)),U)
End DoDot:1
+25 ;
+26 FOR ACHD("I")=1:1:ACHDCVEN
DO ^ACHSDNL2
DO CKPTR
IF X=27!(X=U)
GOTO END
+27 ;
+28 ;FIND ALL 'OTHER PROVIDER ON-FILE' ENTRIES
+29 SET ACHDNAME=""
SET ACHDONFL=1
+30 FOR ACHDVEND=0:0
SET ACHDVEND=$ORDER(^ACHSDEN(DUZ(2),"D",ACHSA,200,ACHDVEND))
IF 'ACHDVEND
QUIT
Begin DoDot:1
+31 SET ACHSVPTR=$PIECE($GET(^ACHSDEN(DUZ(2),"D",ACHSA,200,ACHDVEND,0)),U)
+32 SET ACHDNAME=$PIECE($GET(^AUTTVNDR($PIECE($GET(^ACHSDEN(DUZ(2),"D",ACHSA,200,ACHDVEND,0)),U),0)),U)
FOR ACHD("I")=1:1:ACHDCVEN
DO ^ACHSDNL2
IF X=27!(X=U)
QUIT
End DoDot:1
+33 ;
+34 ;FIND ALL 'OTHER PROVIDER (NOT ON-FILE)' ENTRIES
+35 SET ACHDONFL=0
SET ACHDNODE=210
+36 FOR ACHDVEND=0:0
SET ACHDVEND=$ORDER(^ACHSDEN(DUZ(2),"D",ACHSA,210,ACHDVEND))
IF 'ACHDVEND
QUIT
Begin DoDot:1
+37 SET ACHDNAME=$PIECE($GET(^ACHSDEN(DUZ(2),"D",ACHSA,210,ACHDVEND,0)),U)
+38 SET ACHDADDR=$PIECE($GET(^ACHSDEN(DUZ(2),"D",ACHSA,210,ACHDVEND,0)),U,2,5)
+39 FOR ACHD("I")=1:1:ACHDCVEN
DO ^ACHSDNL2
IF X=27!(X=U)
QUIT
End DoDot:1
+40 ;
+41 ;
PRNTFACT ;
+1 IF ACHDCFAC
FOR ACHD("I")=1:1:ACHDCFAC
DO ^ACHSDNL4
DO CKPTR
IF X=27!(X=U)
GOTO END
+2 IF ACHDBDT
SET ACHDCPAT=ACHD("CPAT")
GOTO S2
END ;
+1 KILL A,ACHDADDR,ACHDOC,ACHDOS,ACHDCFAC,ACHDCPAT,ACHDCVEN,ACHSA,ACHDISDT,ACHDNAME,ACHDNODE,ACHDRQDT,ACHDST,ACHDVEND,ACHDONFL
+2 DO ERPT^ACHS
DO END^ACHSDNL
+3 QUIT
+4 ;
CKPTR ; --- Check if user pressed ESC
+1 IF $DATA(ZTSK)
SET X=0
QUIT
+2 USE IO(0)
+3 READ *X:0
+4 IF X'=27
IF (X'=U)
USE IO
QUIT
+5 WRITE *7,*7,*7
+6 FOR
READ X:0
IF '$TEST
QUIT
+7 WRITE !!,"*** PRINTING INTERRUPTED ***",!
+8 SET X=27
+9 QUIT
+10 ;
PROZ ;
+1 IF $PIECE(ACHDPROZ,U,2)'="Y"
GOTO PROZ1
+2 SET ACHSVPTR=$PIECE(ACHDPROZ,U,3)
+3 SET ACHDONFL=1
+4 SET ACHDNAME=$PIECE($GET(^AUTTVNDR(ACHSVPTR,0)),U)
+5 DO ^ACHSDNL2
+6 GOTO PRNTFACT
+7 ;
PROZ1 ;
+1 IF $PIECE(ACHDPROZ,U,2)'="N"
QUIT
+2 SET ACHDONFL=0
SET ACHDVEND=$PIECE(ACHDPROZ,U,3)
+3 IF 'ACHDVEND
SET ACHDNAME=$PIECE(ACHDPROZ,U)
SET ACHDADDR=$PIECE($GET(^ACHSDEN(DUZ(2),"D",ACHSA,100)),U,3,7)
GOTO PROZ2
+4 SET ACHDNAME=$PIECE($GET(^ACHSDEN(DUZ(2),"D",ACHSA,210,ACHDVEND,0)),U)
+5 ;ACHS*3.1*22 ;CHANGED 3 TO 2 IN NXT LINE
+6 SET ACHDADDR=$PIECE($GET(^ACHSDEN(DUZ(2),"D",ACHSA,210,ACHDVEND,0)),U,2,7)
PROZ2 ;
+1 FOR ACHD("I")=1:1:ACHDCVEN
DO ^ACHSDNL2
+2 GOTO PRNTFACT
+3 ;
