source: FOIAVistA/trunk/r/PATIENT_DATA_EXCHANGE-VAQ/VAQLED07.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 4.5 KB
Line 
1VAQLED07 ;ALB/JFP,JRP - DISPLAY MINIMAL DATA/ADD NEW PATIENT ;01MAR93 [ 12/04/96 9:23 AM ]
2 ;;1.5;PATIENT DATA EXCHANGE;**13,22,23,43**;NOV 17, 1993
3EP ; -- Main entry point for the list processor
4 ; Note: sets flag 'VAQADFL' if required elements are blank
5 ;
6 K ^TMP("VAQD1",$J),^TMP("VAQDIS",$J)
7 S (VAQADFL,VALMCNT)=0
8 ;
9EXTR ; -- Extract PDX minimal data
10 S DFN=DFNTR
11 S ROOT="^TMP(""VAQDIS"",$J)"
12 S SEGPTR=$O(^VAT(394.71,"C","PDX*MIN",""))
13 S VAQIGNC=1 ; -- turns of encryption
14 S X=$$SEGEXT^VAQUPD1(DFN,SEGPTR,ROOT)
15 I +X=-1 W !,"Extract not successful...Error: "_$P(X,U,2) D PAUSE^VALM1 QUIT
16 ; -- extraction sucessful,check for missing data
17 D CHKNULL
18 I VAQADFL=1 D Q
19 .S VAQST="** Unable to load patient...required elements missing"
20 .D EN^VALM("VAQ DIS MIN NUPD") ; -- Protocol = VAQ DIS1 (MENU)
21 S VAQST="** <AP> attempt to add new patient or <RETURN> to exit"
22 D EN^VALM("VAQ DIS MIN UPD") ; -- protocol = VAQ PDX7 (MENU)
23 QUIT
24 ;
25INIT ; -- Builds array of minimal data for the patient entered (DFN)
26 S XTRCT=ROOT
27 S ROOT="^TMP(""VAQD1"",$J)"
28 S (OFFSET,DSP)=0
29 S X=$$DISPMIN^VAQDIS21(XTRCT,SEGPTR,ROOT,OFFSET,DSP)
30 I +X=-1 S MSG="Display load not successful...Error: "_$P(X,U,2) D ERRMSG QUIT
31 S VALMCNT=+X-1
32 D DISMSG
33 K VALMBCK
34 QUIT
35 ;
36HD ; -- Make header line for list processor
37 D HD1^VAQEXT02 QUIT
38 ;
39ADD ; -- Adds new patient to local data base
40 D CLEAR^VALM1
41 W !,"Please wait while information on ",$G(^TMP("VAQDIS",$J,"VALUE",2,.01,0))," is added",!
42 I $G(^TMP("VAQDIS",$J,"VALUE",2,.09,0))'["P",$O(^DPT("SSN",$G(^TMP("VAQDIS",$J,"VALUE",2,.09,0)),"")) D Q
43 . W !!,$C(7),"** Patient not added, SSN in use by existing patient"
44 . W !
45 . D TRANEX
46 S DIC="^DPT("
47 S DIC(0)="EL"
48 S DLAYGO=2
49 S X=$G(^TMP("VAQDIS",$J,"VALUE",2,.01,0))
50 S DIC("DR")=".03///"_$G(^TMP("VAQDIS",$J,"VALUE",2,.03,0))
51 F I=.09,391,1901 S DIC("DR")=DIC("DR")_";"_I_"///"_$G(^TMP("VAQDIS",$J,"VALUE",2,I,0))
52 K DD,D0 D FILE^DICN K DIC,DLAYGO
53 I $P(Y,U,3)'=1 W !!,$C(7),"** Patient not added",! D TRANEX QUIT
54 ;
55 ; -- Update workload file (new patient)
56 D WORKLD
57 ; -- Add rest of information for stub"
58 S VAQSTUB=+Y
59 S LOCKFLE=$G(^DIC(2,0,"GL"))
60 L +(@(LOCKFLE_VAQSTUB_")")):60
61 I ('$T) W !,"Could not edit entry...record locked" K LOCKFLE QUIT
62 F FLD=.02,.05,.08,.301,.302,.361,.323,.111,.112,.113,.114,.115,.1112,.117 D LOAD
63 ; -- load temporary address information, if active
64 D TMPADDR QUIT
65 L -(@(LOCKFLE_VAQSTUB_")")) K LOCKFLE
66 W !,"** PDX minimal information on ",$G(^TMP("VAQDIS",$J,"VALUE",2,.01,0))," has been added"
67 D TRANEX
68 D EP^VAQLED02
69 K VALMBCK
70 QUIT
71 ;
72LOAD ; -- Loads fields to patient file
73 S DIE=2,(DA,DFNPT)=VAQSTUB
74 S DR=FLD_"///^S X=$G(^TMP(""VAQDIS"",$J,""VALUE"",2,FLD,0))"
75 D ^DIE K DIE,DA,DR
76 I ($D(Y)#2) W ?10,"- ",$P(^DD(2,FLD,0),U,1),?40," could not be added",!
77 QUIT
78 ;
79TMPADDR ; -- Checks to see if temporary address dates are active and flag set
80 ; -- active flag
81 I $G(^TMP("VAQDIS",$J,"VALUE",2,.12105,0))="Y" QUIT ;strt dte
82 I $G(^TMP("VAQDIS",$J,"VALUE",2,.1217,0))'<DT QUIT ;strt dte
83 I $G(^TMP("VAQDIS",$J,"VALUE",2,.1218,0))'>DT QUIT ;end dte
84 ; -- Load temporary address fields
85 F FLD=.12105,.1211,.12111,.12112,.1212,.1213,.1214,.1215,.12112,.1217,.1218,.1219 D LOAD
86 QUIT
87 ;
88ERRMSG ; -- Displays error message
89 S X=$$SETSTR^VALM1(" ","",1,79) D TMP
90 S X=$$SETSTR^VALM1(MSG,"",1,80) D TMP
91 S VALMBCK="Q"
92 QUIT
93 ;
94DISMSG ; -- Display status message
95 S X=$$SETSTR^VALM1(VAQST,"",1,79) D TMP
96 K VAQLN,VAQST
97 QUIT
98 ;
99TMP ; -- Set the array used by list processor
100 S VALMCNT=VALMCNT+1
101 S ^TMP("VAQD1",$J,VALMCNT,0)=$E(X,1,79)
102 QUIT
103 ;
104CHKNULL ; -- Sets missing data flag if it finds a required field null
105 ; Added quit condition. NOIS ISD-0495-40199
106 S FLD=""
107 F FLD=.01,.02,.03,.05,.08,.09,.111,.114,.115,.1112,.117,.323,.361,391,1901 Q:(VAQADFL=1) D
108 .S VAQDATA=$G(^TMP("VAQDIS",$J,"VALUE",2,FLD,0))
109 .S:VAQDATA="" VAQADFL=1
110 I VAQADFL=0 D
111 .S:($G(^TMP("VAQDIS",$J,"VALUE",2,.302,0))=""&($G(^TMP("VAQDIS",$J,"VALUE",2,.301,0))'="NO")) VAQADFL=0
112 K FLD,VAQDATA
113 QUIT
114 ;
115TRANEX ; -- Transaction exit
116 D PAUSE^VALM1
117 S VALMBCK="Q"
118 QUIT
119 ;
120WORKLD ; -- Updates work load file
121 S X=$$WORKDONE^VAQADS01("NEW",DFNTR,$G(DUZ))
122 I +X<0 W !,"Error updating work loadfile (NEW)... "_$P(X,U,2)
123 I $P($G(^VAT(394.61,DFNTR,0)),U,4)=0 QUIT
124 S X=$$WORKDONE^VAQADS01("SNSTVE",DFNTR,$G(DUZ))
125 I X<0 W !,"Error updating workload file (SNSTVE)... "_$P(X,U,2)
126 QUIT
127 ;
128EXIT ; -- Note: The list processor cleans up its own variables.
129 ; All other variables cleaned up here.
130 ;
131 K ^TMP("VAQD1",$J),^TMP("VAQDIS",$J)
132 K VAQADFL,VAQSTUB,VAQIGNC
133 K VALMCNT,ROOT,SEGPTR,X,MSG,XTRCT,OFFSET,DSP
134 Q
135 ;
136END ; -- End of code
137 QUIT
Note: See TracBrowser for help on using the repository browser.