source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGQEMA.m@ 1259

Last change on this file since 1259 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.7 KB
Line 
1DGQEMA ;RWA/SLC-DHW/OKC-ALB/MIR - EMBOSSER AUTO QUEUE;03/21/85 2:31 PM ; 04 Oct 85 10:24 AM
2 ;;5.3;Registration;**73,191**;Aug 13, 1993
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ;INPUT: DFN - patient (NOT killed on exit unless manuel q)
6 ;
7 ;USED: DGHD - HOLD? (1 for yes, 2 for no, 0 for ask)
8 ; DGQUAN - how many cards?
9 ; S - type of card (1 for NSC, 2 for SC, 3 for NON-VET,
10 ; and 9 for FREE TEXT)
11 ; DGFL - 1 if '^', 2 for time-out, otherwise 0
12 ; DGLINE - Lines of text subscripted by line #
13 ; DGE - errors? Yes if $D(DGE)
14 ;
15EN S L=0 I $S('$D(DFN):1,'$D(^DPT(+DFN,0)):1,1:0) G END
16 S X=$P(^DPT(DFN,0),"^",1) I X?.E1L.E D FUNC S DIE=2,DA=DFN,DR=".01///"_X D ^DIE
17CKADD I $D(^DPT(DFN,.11)) S X=$P(^DPT(DFN,.11),"^",1) I X["#" D ADD G CKADD
18 I X?.E1L.E D FUNC S DIE=2,DA=DFN,DR=".111///"_X D ^DIE
19 I $D(^DPT(DFN,.11)) S X=$P(^DPT(DFN,.11),"^",4) I X?.E1L.E D FUNC S DIE=2,DA=DFN,DR=".114///"_X D ^DIE
20 S:'$D(DGHD) DGHD=0
21 I $D(^DPT(DFN,"VET")),(^DPT(DFN,"VET")="N") S S=3 G CONT
22 I '$D(^DPT(DFN,.3)) D MSG G END
23 S X=$P(^DPT(DFN,.3),"^",1)
24 S V="" I $D(^DPT(DFN,.361)) S V=$P(^DPT(DFN,.361),"^",1)
25 S S=$S(X?1"Y"&(V?1"V"):2,X?1"Y"&(V'?1"V"):1,X?1"N":1,1:"") I S="" G END
26 I X?1"Y"&(V'?1"V") W !,"Service connected eligibility NOT verified",!,"Card will be queued as Non service connected (blue)",!
27 ;
28CONT S S=$O(^DIC(39.1,"C",S,"")) I $S('S:1,'$D(^DIC(39.1,S,0)):1,'$P(^(0),"^",6):1,1:0) W !,"Embosser files not correctly set up...contact your site manager" G END
29 S DGX=^DIC(39.1,S,0),S=$P(DGX,"^",6)
30 D ERROR^DGQEMA1 ;check that data elements are complete
31 I $D(DGE) D OK I 'DGFL G END
32 S:'$D(DGQUAN) DGQUAN=$P(DGX,"^",4) S:'DGQUAN DGQUAN=1
33 F K=1:1:7 S DGLINE(K)="" F DGI=0:0 S DGI=$O(^DIC(39.1,S,1,K,1,DGI)) Q:'DGI I $D(^(DGI,0)) S DGJ=^(0) D DATA
34 F K=8,9 D FT^DGQEMA1 I DGFL Q
35 I DGFL=2 W !,*7,"Data card NOT queued" G END
36 S DGTYP=S D ^DGQEMA1 ;hold or print
37 ;
38END K %,%Y,D,S,X,Y,L,AMT,DA,DGA,DGBLK,DGE,DGFL,DGHD,DGHOL,DGI,DGJ,DGLINE,DGQUAN,DGTYP,DGX,DIC,DIE,DR,DTOUT,I,K,V,Z
39 K ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
40 Q
41 ;
42FUNC S I=$O(^DD("FUNC","B","UPPERCASE",0)) X:$D(^DD("FUNC",+I,1)) ^DD("FUNC",I,1)
43 Q
44 ;
45ADD S I=$F(X,"#") S X1=$E(X,1,I-2) S X=X1_" "_$E(X,I,99) S DIE=2,DA=DFN,DR=".111///"_X D ^DIE
46 K X1 Q
47 ;
48DATA ;get lines 1-7 for data card per file 39.2
49 ;DGJ=ptr to xecutable code^start position^length
50 Q:'$D(^DIC(39.2,+DGJ,1)) X ^(1)
51 K DGBLK S $P(DGBLK," ",80)=""
52 S DGLINE(K)=$E(DGLINE(K)_DGBLK,1,$P(DGJ,"^",2)-1)_$E(Y_DGBLK,1,$P(DGJ,"^",3))
53 Q
54 ;
55 ;
56MAN ;manuel Q
57 F DGPT=1:1:10 S DIC="^DPT(",DIC(0)="AEQMZ" W ! D ^DIC Q:Y'>0 S DFN=+Y D NUM Q:DGMANFL=2 I 'DGMANFL D EN
58 K DFN,DGMANFL,DGPT,DIC,X,Y Q
59 ;
60NUM ;how many cards...set DGQUAN
61 S DGMANFL=0 R !,"Number of cards to print (1-8): 1//",X:DTIME I '$T S DGMANFL=2 Q
62 I X["^" S DGMANFL=1 Q
63 I X="" S X=1 W X
64 I X'>0!(X'<9) W !?3,"Enter the number of cards you wish to print (1-8)" G NUM
65 S DGQUAN=X
66 Q
67 ;
68 ;
69MSG ;print error message if card can't be printed
70 W !,"Service connected or NSC status not entered...cannot print card"
71 Q
72 ;
73 ;
74OK ;ask if ok to print data cards if data missing
75 S DGFL=0 N S W !,"Do you still wish to emboss a patient data card" S %=2 D YN^DICN
76 I %=0 W !?3,"Enter 'Y'es to emboss a card, otherwise, 'N'o." G OK
77 I %=1 S DGFL=1
78 Q
79 ;
80 ;
81EMBOS ; -- Ask if user wants to emboss (OLD) data card, downloads data to VIC.
82 ; Called from DGREG00, DG10, and DG1010P
83 ; -- Download VIC Data
84 D VIC^DGQESC5
85 Q ;Do not do old card anymore patch 191
86OLD ; -- Creates old card, if flag set in MAS parameter file
87 S Y=$P(^DG(43,1,0),U,28) Q:'Y W !,"EMBOSS (OLD) DATA CARD" S %=2 D YN^DICN I %=-1!(%=2) Q
88 I %=0 W !," Enter YES to print patient data card for this patient, otherwise respond NO" G OLD
89 I %=1 D EN
90 Q
91 ;
Note: See TracBrowser for help on using the repository browser.