- 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
