| 1 | VWREGITP ;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 | ;
|
|---|
| 10 | GPD(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
|
|---|
| 36 | GPDM(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
|
|---|
