source: VWGUIRegistration/trunk/VWREGITP.m@ 1798

Last change on this file since 1798 was 1798, checked in by Jim B., 8 years ago
File size: 2.3 KB
Line 
1VWREGITP ;BFP/Portland,OR-Jim Bell,et al - Client Registration Utility
2 ;2.0;BFP for WorldVistA;**LOCAL**;;;Build 2
3 ; *******************************************
4 ; * Copyright 2015 ad infinitum et ultra *
5 ; * Gets data for existing clients/patients *
6 ; * GPL License: See License.txt *
7 ; *******************************************
8 Q ;No fall through - jeb
9 ;
10GPD(RESULT,DATA) ;Get patient data
11 ; ********************************* 8888***
12 ; * DATA_____TEMPLATE(IEN)^FIELDSET^DFN *
13 ; * TEMPLATE__The name(IEN) of a *
14 ; * stored template *
15 ; * FIELDSET_Adhoc fields in a string *
16 ; * as ".01;3;5;.131", etc *
17 ; * DFN______IEN of patient file(#2) *
18 ; * NOTE: TEMPLATE takes precedence *
19 ; * over FIELDSET *
20 ; *****************************************
21 ;
22 K RESULT,AR
23 N VAR,TNUM,FSET,F,DFN
24 I '$L(DATA) S RESULT(0)="No information relayed. Please try again" Q
25 I $P(DATA,"^",3)="" S RESULT(0)="Patient info not relayed. Please try again" Q
26 S VAR="TNUM^ADHOC^DFN" F I=1:1:3 S @$P(VAR,"^",I)=$P(DATA,"^",I)
27 S TNUM=$S(TNUM["(":+$P(TNUM,"(",2),1:TNUM)
28 S DFN=+$P($P(DATA,"^",3),"(",2)
29 S FSET=$S(TNUM:^DIE(TNUM,"DR",1,2),'TNUM&($L(ADHOC)):ADHOC,1:"")
30 D GETS^DIQ(2,DFN_",","**","N","AR")
31 F I=1:1:$L(FSET,";") D
32 . Q:'$L($P(FSET,";",I))
33 . S F=+$P(FSET,";",I)
34 . S RESULT($$INR^VWREGIT)=F_"^"_$G(AR(2,DFN_",",F))
35 Q
36GPDM(RESULT,DATA) ;
37 ; ****************************************************************
38 ; * DATA____Parent Text^Parent field #^PATIENT IEN^TEMPLATE(IEN) *
39 ; ****************************************************************
40 N F,SUBD,DFN,PIEN,X,RIND,FILE,X,Y,TNUM
41 K MX,MAR,RESULT,AR
42 S DFN=+$P(DATA,"^",3)
43 S F=+$P(DATA,"^",2)
44 S TNUM=+$P($P(DATA,"^",4),"(",2)
45 D GETS^DIQ(2,DFN_",",F_"*;","E","AR")
46 S SUBD=+$P(^DD(2,F,0),"^",2) D:+SUBD ;Multiple field values
47 . S MX="AR("_SUBD_")" F S MX=$Q(@MX) Q:MX=""!(+$P(MX,"(",2)'=SUBD) D:$P(MX,",",$L(MX,",")-1)'=.01
48 .. S FILE=SUBD,PIEN=$P(MX,",",2,$L(MX,",")-1),PIEN=$TR(PIEN,"""","")
49 .. K MAR,IMAR
50 .. D GETS^DIQ(FILE,PIEN,"**","E","MAR")
51 .. D GETS^DIQ(FILE,PIEN,"**","I","IMAR")
52 .. S X=$Q(@"MAR"),Y=$Q(@"IMAR")
53 .. I @X'=@Y S @X=@X_"("_@Y_")"
54 .. S X="MAR" ;,RIND=$$INR^VWREGIT
55 .. S RIND=$$INR^VWREGIT,RESULT(RIND)="" F S X=$Q(@X) Q:X="" S RESULT(RIND)=RESULT(RIND)_@X_"^"
56 K AR,MAR,IMAR,MX
57 Q
Note: See TracBrowser for help on using the repository browser.