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

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

initial load of WorldVistAEHR

File size: 2.9 KB
RevLine 
[613]1DGQESC5 ;ALB/JFP - ID Card - standalone;01/09/96
2 ;;V5.3;REGISTRATION;**73**;DEC 11,1996
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5VIC ; -- Ask if user wants to download demographic data to photo capture
6 ; station. Checks MAS paramter file. Called from DGREG00, DG10,
7 ; and DG1010P.
8 ;S Y=$P(^DG(43,1,0),U,28) Q:'Y
9 W !,"Download VIC data" S %=2 D YN^DICN I %=-1!(%=2) Q
10 I %=0 W !," Enter YES to download patient demographic data to photo capture station" G VIC
11 I %=1 D EN
12 Q
13 ;
14MAN ; -- Entry point for manual card
15 F S DIC="^DPT(",DIC(0)="AEQMZ" W ! D ^DIC Q:($D(DTOUT)!(Y'>0)) S DFN=+Y D EN
16 K DFN,DGPT,DIC,X,Y
17 Q
18 ;
19EN ; -- Main entry point for VIC download
20 ; -- Checks for valid DFN
21 S L=0 I $S('$D(DFN):1,'$D(^DPT(+DFN,0)):1,1:0) G EXIT
22 ; -- Set Variables for VIC card
23 ;S S=4 ; VIC card entry in embosser file 39.1
24 ; -- Ensure uppercase
25 S X=$P(^DPT(DFN,0),"^",1)
26 I X?.E1L.E D FUNC S DIE=2,DA=DFN,DR=".01///"_X D ^DIE
27CKADD ; -- Checks address
28 I $D(^DPT(DFN,.11)) S X=$P(^DPT(DFN,.11),"^",1) I X["#" D ADD G CKADD
29 I X?.E1L.E D FUNC S DIE=2,DA=DFN,DR=".111///"_X D ^DIE
30 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
31 ; -- Check Embosser file for entry
32 ;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 EXIT
33 ; -- checks for required data elements
34 D ERROR
35 I $D(DGE) D OK I 'DGFL G EXIT
36DOWN ; -- Call routine to download information via HL7 to photo capture stat
37 S RESULTS=$$EVENT^DGQEHL71("A08",DFN)
38 I $P(RESULTS,"^",1)=-1 W !,"Data not downloaded. Error - ",$P(RESULTS,"^",2)
39 W:$P(RESULTS,"^",1)'=-1 !,"Data Download successfully to VIC"
40 ;
41EXIT K %,S,X,Y,L,DA,DGE,DGFL,DIE,DR,I,RESULTS
42 Q
43 ;
44FUNC ; -- Convert characters from lower case to uppercase
45 S I=$O(^DD("FUNC","B","UPPERCASE",0)) X:$D(^DD("FUNC",+I,1)) ^DD("FUNC",I,1)
46 Q
47 ;
48ADD ; -- Strips # characters, updates field
49 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
50 K X1 Q
51 ;
52OK ; -- Ask if ok to download data, if data missing
53 S DGFL=0 N S W !,"Do you still wish to download data " S %=2 D YN^DICN
54 I %=0 W !?3,"Enter 'Y'es to download data, otherwise, 'N'o." G OK
55 I %=1 S DGFL=1
56 Q
57 ;
58ERROR ;Error messages for incomplete data
59 I $S('$D(^DPT(DFN,.36)):1,'^(.36):1,1:0) S DGE=1 S Y="ELIGIBILITY CODE" D ERR
60 I $D(^DPT(DFN,"VET")),(^DPT(DFN,"VET")="N") G NONVET
61 I $S('$D(^DPT(DFN,.32)):1,'$P(^(.32),"^",3):1,1:0) S Y="PERIOD OF SERVICE" D ERR
62 I $S('$D(^DPT(DFN,.31)):1,$P(^(.31),"^",3)']"":1,1:0) S Y="CLAIM NUMBER" D ERR
63NONVET S X=^DPT(DFN,0) F I=1,2,3,5,8,9 I $P(X,"^",I)="" S Y=$P(^DD(2,".0"_I,0),"^",1) D ERR
64 I $D(^DPT(DFN,.11)) S X=^DPT(DFN,.11) F I=1,4,5,6,7 I $P(X,"^",I)="" S Y=$P(^DD(2,".11"_I,0),"^",1) D ERR
65 I '$D(^DPT(DFN,.11)) S DGE=1 S Y="ADDRESS DATA" D ERR Q
66 Q
67 ;
68ERR W !," - ",Y," MISSING" S DGE=1 Q
69END ; -- End of code
70 Q
71 ;
Note: See TracBrowser for help on using the repository browser.