DGQEMP ;RWA/SLC-DHW/OKC-ALB/MIR - EMBOSSER PRINT;04/02/85 5:48 PM ; 11 Feb 86 10:04 AM
;;5.3;Registration;**1015**;Aug 13, 1993;Build 21
;
;DGEMBTYP = device type (1 for embosser, 2 for addressograph, and 0 for plain printer
;
EN S %ZIS="",IOP="HOME" D ^%ZIS S DGI=$O(^DIC(39.3,"B",ION,0)),DGEMBTYP=0 K IOP,%ZIS
I DGI,$D(^DIC(39.3,DGI,0)) S DGEMBTYP=$P(^(0),"^",2)
I DGEMBTYP<0!(DGEMBTYP>2) G Q
K DGFORMAT,CARD S (DGCOUNT,DGTRY,DGSOFT,DGHARD,DGUNK)=0
PRINT S:'$D(DGQUAN) DGQUAN=1 S ERR=0 D @(DGEMBTYP)
I ERR S DGTRY=DGTRY+1 D MAIL G:'REC&(DGTRY'>2) PRINT D HOLD^DGQEMA1
;
;update file statistics
;
I 'DGI G Q
I '$D(^DIC(39.3,DGI,1,0)) S ^DIC(39.3,DGI,1,0)="^39.31A^^"
S X="" I $D(^DIC(39.3,DGI,1,DT,0)) S X=^(0)
S DGNUM=$P(X,"^",1),DGSOFER=$P(X,"^",2),DGHER=$P(X,"^",3),DGUKER=$P(X,"^",4)
S DIC="^DIC(39.3,"_DGI_",1,"
I '$D(^DIC(39.3,DGI,1,DT)) S DINUM=DT,DIC(0)="L",DA(1)=DGI,X=DGCOUNT D ^DIC
I $D(^DIC(39.3,DGI,1,DT)) S DIE=DIC,DA=DT,DR=".01///"_(DGCOUNT+DGNUM)_";1///"_(DGSOFT+DGSOFER)_";2///"_(DGHARD+DGHER)_";3///"_(DGUNK+DGUKER) D ^DIE
;I DGCOUNT<DGQUAN S DGQUAN=DGQUAN-DGCOUNT G PRINT
Q D KILL^%ZTLOAD K DFN,DGCOUNT,DGCT,DGEMBTYP,DGHARD,DGF,DGFORMAT,DGHER,DGI,DGLINE,DGNUM,DGQUAN,DGSOFER,DGSOFT,DGTRY,DGUKER,DGUNK,ERR,F,FM,I,J,K,POP,REC,X,XMB,XMDUZ,Y
K DA,DIC,DIE,DINUM
Q
MAIL I $L($P(^DIC(39.1,DGTYP,0),"^",5)),$P(^(0),"^",5)="Y" S XMY(DUZ)=""
S XMDUZ=.5,XMB=$S(REC:"DG EMBOSSER1",1:"DG EMBOSSER"),XMB($S(REC:1,1:2))=$S($D(^DPT(+DFN,0)):$P(^(0),"^",1),1:"UNSPECIFIED")
I 'REC S XMB(1)=$P(^DIC(39.1,DGTYP,0),"^",1)
D ^XMB
K XMB,XMDUZ Q
;
;
BATCH ;process cards in hold status
F DGCD=0:0 S DGCD=$O(^DIC(39.1,DGTYP,"HOLD",DGCD)) Q:'DGCD I $D(^(DGCD,0)) S DFN=+^(0),DGQUAN=$P(^(0),"^",2) D TEXT
S DIK="^DIC(39.1,"_DGTYP_",""HOLD"",",DA(1)=DGTYP F DA=0:0 S DA=$O(^DIC(39.1,DGTYP,"HOLD",DA)) Q:'DA D ^DIK
K DA,DIK,DGCD,DGTYP Q
;
TEXT ;get text from cards in hold
F K=1:1:9 I $D(^DIC(39.1,DGTYP,"HOLD",DGCD,1,K,0)) S DGLINE(K)=^(0)
I $D(DGLINE(1)) D EN ;print card
Q
;
;
;WARNING!!!
;This section prints the patient data cards and interacts with the
;embosser and addressograph
;
;Line tags:
; 0 - for plain printer
; 1 - for embosser
; 2 - for addressograph
;
;
0 ;plain paper printer
F I=1:1:DGQUAN S DGCOUNT=DGCOUNT+1 W:I>1 !!!!!! F L=1:1:9 I $D(DGLINE(L)) W !,DGLINE(L)
W @IOF
Q
;
;
1 ;embosser
S (REC,F,K,X)=0,DGF=2 X ^%ZOSF("EOFF"),^%ZOSF("TYPE-AHEAD")
S FM=$S($D(DGFORMAT):9,1:0)
F I=1:1 R *X:0 Q:'$T
A0 R *X:30 S X=$C(X) I X="" S DGUNK=1 G ERR
I FM=1 S FM=2 G S1:X="B",H1:X="H",X1:X'="C" S DGFORMAT=1 G A0
G A1:X="A",H1:X="H",S1:X="B",X1
;
A1 G S2:'FM D SB1 S REC=1
F I=1:1:DGQUAN R *X:200 S X=$C(X) G S1:X="B",H1:X="H",X1:X'="C" S K=K+1
G END
S1 G ERR:F>DGF R *X:30 S X=$C(X),F=F+1,DGSOFT=DGSOFT+1 G H1:X="H",ERR:X'="A"
S2 D SB2 S FM=1 G A0
H1 S DGHARD=DGHARD+1 G ERR
X1 S DGUNK=DGUNK+1 G ERR:F>DGF S F=F+1 G A0
ERR S ERR=1
END S DGCOUNT=K Q
SB1 W "#DCC##REP#",DGQUAN,"#EMB#" F L=1:1:9 Q:'$D(DGLINE(L)) W DGLINE(L),""""
W "#END#@@@@@@" Q
SB2 W "#DCL#080400 1#FC1#1550 2#FC1#1400 3#FC1#1250"
W " 4#FC1#1100 5#FC1#0950 6#FC1#0800 7#FC1#0650"
W " 8#FC1#0500 9#FC1#0350#END#@@@@@@" Q
;
;
2 ;addressograph
F I=1:1:DGQUAN D ADD S DGCOUNT=DGCOUNT+1
Q
ADD F L=1:1:12 W *0
W "<" F L=1:1:9 Q:'$D(DGLINE(L)) W !,"+00000",(L-1),"0",DGLINE(L)
W ">" Q
DGQEMP ;RWA/SLC-DHW/OKC-ALB/MIR - EMBOSSER PRINT;04/02/85 5:48 PM ; 11 Feb 86 10:04 AM
+1 ;;5.3;Registration;**1015**;Aug 13, 1993;Build 21
+2 ;
+3 ;DGEMBTYP = device type (1 for embosser, 2 for addressograph, and 0 for plain printer
+4 ;
EN SET %ZIS=""
SET IOP="HOME"
DO ^%ZIS
SET DGI=$ORDER(^DIC(39.3,"B",ION,0))
SET DGEMBTYP=0
KILL IOP,%ZIS
+1 IF DGI
IF $DATA(^DIC(39.3,DGI,0))
SET DGEMBTYP=$PIECE(^(0),"^",2)
+2 IF DGEMBTYP<0!(DGEMBTYP>2)
GOTO Q
+3 KILL DGFORMAT,CARD
SET (DGCOUNT,DGTRY,DGSOFT,DGHARD,DGUNK)=0
PRINT IF '$DATA(DGQUAN)
SET DGQUAN=1
SET ERR=0
DO @(DGEMBTYP)
+1 IF ERR
SET DGTRY=DGTRY+1
DO MAIL
IF 'REC&(DGTRY'>2)
GOTO PRINT
DO HOLD^DGQEMA1
+2 ;
+3 ;update file statistics
+4 ;
+5 IF 'DGI
GOTO Q
+6 IF '$DATA(^DIC(39.3,DGI,1,0))
SET ^DIC(39.3,DGI,1,0)="^39.31A^^"
+7 SET X=""
IF $DATA(^DIC(39.3,DGI,1,DT,0))
SET X=^(0)
+8 SET DGNUM=$PIECE(X,"^",1)
SET DGSOFER=$PIECE(X,"^",2)
SET DGHER=$PIECE(X,"^",3)
SET DGUKER=$PIECE(X,"^",4)
+9 SET DIC="^DIC(39.3,"_DGI_",1,"
+10 IF '$DATA(^DIC(39.3,DGI,1,DT))
SET DINUM=DT
SET DIC(0)="L"
SET DA(1)=DGI
SET X=DGCOUNT
DO ^DIC
+11 IF $DATA(^DIC(39.3,DGI,1,DT))
SET DIE=DIC
SET DA=DT
SET DR=".01///"_(DGCOUNT+DGNUM)_";1///"_(DGSOFT+DGSOFER)_";2///"_(DGHARD+DGHER)_";3///"_(DGUNK+DGUKER)
DO ^DIE
+12 ;I DGCOUNT<DGQUAN S DGQUAN=DGQUAN-DGCOUNT G PRINT
Q DO KILL^%ZTLOAD
KILL DFN,DGCOUNT,DGCT,DGEMBTYP,DGHARD,DGF,DGFORMAT,DGHER,DGI,DGLINE,DGNUM,DGQUAN,DGSOFER,DGSOFT,DGTRY,DGUKER,DGUNK,ERR,F,FM,I,J,K,POP,REC,X,XMB,XMDUZ,Y
+1 KILL DA,DIC,DIE,DINUM
+2 QUIT
MAIL IF $LENGTH($PIECE(^DIC(39.1,DGTYP,0),"^",5))
IF $PIECE(^(0),"^",5)="Y"
SET XMY(DUZ)=""
+1 SET XMDUZ=.5
SET XMB=$SELECT(REC:"DG EMBOSSER1",1:"DG EMBOSSER")
SET XMB($SELECT(REC:1,1:2))=$SELECT($DATA(^DPT(+DFN,0)):$PIECE(^(0),"^",1),1:"UNSPECIFIED")
+2 IF 'REC
SET XMB(1)=$PIECE(^DIC(39.1,DGTYP,0),"^",1)
+3 DO ^XMB
+4 KILL XMB,XMDUZ
QUIT
+5 ;
+6 ;
BATCH ;process cards in hold status
+1 FOR DGCD=0:0
SET DGCD=$ORDER(^DIC(39.1,DGTYP,"HOLD",DGCD))
IF 'DGCD
QUIT
IF $DATA(^(DGCD,0))
SET DFN=+^(0)
SET DGQUAN=$PIECE(^(0),"^",2)
DO TEXT
+2 SET DIK="^DIC(39.1,"_DGTYP_",""HOLD"","
SET DA(1)=DGTYP
FOR DA=0:0
SET DA=$ORDER(^DIC(39.1,DGTYP,"HOLD",DA))
IF 'DA
QUIT
DO ^DIK
+3 KILL DA,DIK,DGCD,DGTYP
QUIT
+4 ;
TEXT ;get text from cards in hold
+1 FOR K=1:1:9
IF $DATA(^DIC(39.1,DGTYP,"HOLD",DGCD,1,K,0))
SET DGLINE(K)=^(0)
+2 ;print card
IF $DATA(DGLINE(1))
DO EN
+3 QUIT
+4 ;
+5 ;
+6 ;WARNING!!!
+7 ;This section prints the patient data cards and interacts with the
+8 ;embosser and addressograph
+9 ;
+10 ;Line tags:
+11 ; 0 - for plain printer
+12 ; 1 - for embosser
+13 ; 2 - for addressograph
+14 ;
+15 ;
0 ;plain paper printer
+1 FOR I=1:1:DGQUAN
SET DGCOUNT=DGCOUNT+1
IF I>1
WRITE !!!!!!
FOR L=1:1:9
IF $DATA(DGLINE(L))
WRITE !,DGLINE(L)
+2 WRITE @IOF
+3 QUIT
+4 ;
+5 ;
1 ;embosser
+1 SET (REC,F,K,X)=0
SET DGF=2
XECUTE ^%ZOSF("EOFF")
XECUTE ^%ZOSF("TYPE-AHEAD")
+2 SET FM=$SELECT($DATA(DGFORMAT):9,1:0)
+3 FOR I=1:1
READ *X:0
IF '$TEST
QUIT
A0 READ *X:30
SET X=$CHAR(X)
IF X=""
SET DGUNK=1
GOTO ERR
+1 IF FM=1
SET FM=2
IF X="B"
GOTO S1
IF X="H"
GOTO H1
IF X'="C"
GOTO X1
SET DGFORMAT=1
GOTO A0
+2 IF X="A"
GOTO A1
IF X="H"
GOTO H1
IF X="B"
GOTO S1
GOTO X1
+3 ;
A1 IF 'FM
GOTO S2
DO SB1
SET REC=1
+1 FOR I=1:1:DGQUAN
READ *X:200
SET X=$CHAR(X)
IF X="B"
GOTO S1
IF X="H"
GOTO H1
IF X'="C"
GOTO X1
SET K=K+1
+2 GOTO END
S1 IF F>DGF
GOTO ERR
READ *X:30
SET X=$CHAR(X)
SET F=F+1
SET DGSOFT=DGSOFT+1
IF X="H"
GOTO H1
IF X'="A"
GOTO ERR
S2 DO SB2
SET FM=1
GOTO A0
H1 SET DGHARD=DGHARD+1
GOTO ERR
X1 SET DGUNK=DGUNK+1
IF F>DGF
GOTO ERR
SET F=F+1
GOTO A0
ERR SET ERR=1
END SET DGCOUNT=K
QUIT
SB1 WRITE "#DCC##REP#",DGQUAN,"#EMB#"
FOR L=1:1:9
IF '$DATA(DGLINE(L))
QUIT
WRITE DGLINE(L),""""
+1 WRITE "#END#@@@@@@"
QUIT
SB2 WRITE "#DCL#080400 1#FC1#1550 2#FC1#1400 3#FC1#1250"
+1 WRITE " 4#FC1#1100 5#FC1#0950 6#FC1#0800 7#FC1#0650"
+2 WRITE " 8#FC1#0500 9#FC1#0350#END#@@@@@@"
QUIT
+3 ;
+4 ;
2 ;addressograph
+1 FOR I=1:1:DGQUAN
DO ADD
SET DGCOUNT=DGCOUNT+1
+2 QUIT
ADD FOR L=1:1:12
WRITE *0
+1 WRITE "<"
FOR L=1:1:9
IF '$DATA(DGLINE(L))
QUIT
WRITE !,"+00000",(L-1),"0",DGLINE(L)
+2 WRITE ">"
QUIT
