source: WorldVistAEHR/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTQAPI11.m@ 789

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

initial load of WorldVistAEHR
File size: 4.6 KB
RevLine 
[613]1YTQAPI11 ;ASF/ALB MHAx API ; 4/3/07 11:03am
2 ;;5.01;MENTAL HEALTH;**85**;DEC 30,1994;Build 49
3SCORSAVE(YSDATA,YS) ;save results to 601.92
4 ; input: AD as administration ID
5 ; output: DATA vs ERROR
6 N YSAD,DIK,YSG,YSRNEW,Z
7 S YSAD=$G(YS("AD"))
8 I YSAD'?1N.N S YSDATA(1)="[ERROR]",YSDATA(2)="bad ad num" Q ;-->out
9 I '$D(^YTT(601.84,YSAD)) S YSDATA(1)="[ERROR]",YSDATA(2)="ad not found" Q ;-->out
10 D GETSCORE^YTQAPI8(.YSDATA,.YS)
11 I $G(^TMP($J,"YSCOR",1))'="[DATA]" S YSDATA="[ERROR]",YSDATA(2)="getscore err" Q ;-->out
12 ;delete any previous scores for this admin
13 S DIK="^YTT(601.92,",DA=0
14 F S DA=$O(^YTT(601.92,"AC",YSAD,DA)) Q:DA'>0 D ^DIK
15 ;ADD SCORES
16 S Z=1 F S Z=$O(^TMP($J,"YSCOR",Z)) Q:Z'>0 D
17 . S YSG=^TMP($J,"YSCOR",Z)
18 . S YSRNEW=$$NEW^YTQLIB(601.92)
19 . S ^YTT(601.92,YSRNEW,0)=YSRNEW_U_YSAD_U_$P(YSG,"=")_U_$P(YSG,"=",2)
20 . S DA=YSRNEW D IX^DIK
21 S YSDATA(1)="[DATA]"
22 Q
23SCALES ;from copy
24 S YSSGOLD=0 F S N=$O(^YTT(601.86,"AD",YSOLDNUM,YSSGOLD)) Q:YSSGOLD'>0 D
25 . S YSSGNEW=$$NEW^YTQLIB(601.86)
26 . S ^YTT(601.86,YSSGNEW,0)=^YTT(601.86,YSSGOLD,0)
27 . S $P(^YTT(601.86,YSSGNEW,0),U)=YSSGNEW
28 . S $P(^YTT(601.86,YSSGNEW,0),U,2)=YSNEWNUM
29 . S DA=YSSGNEW,DIK="^YTT(601.86," D IX^DIK
30 . S YSSLOLD=0 F S YSN1=$O(^YTT(601.87,"AD",YSSGOLD,YSSLOLD)) Q:YSSLOLD'>0 D
31 .. S YSSLNEW=$$NEW^YTQLIB(601.87)
32 .. S ^YTT(601.87,YSSLNEW,0)=^YTT(601.87,YSSLOLD,0)
33 .. S $P(^YTT(601.87,YSSLNEW,0),U)=YSSLNEW
34 .. S $P(^YTT(601.87,YSSLNEW,0),U,2)=YSSGNEW
35 .. S DA=YSSLNEW,DIK="^YTT(601.87," D IX^DIK
36 .. S YSKEYOLD=0 F S YSKEYOLD=$O(^YTT(601.91,"AC",YSSLOLD,YSKEYOLD)) Q:YSKEYOLD'>0 D
37 ... S YSKEYNEW=$$NEW^YTQLIB(601.91)
38 ... S ^YTT(601.91,YSKEYNEW,0)=^YTT(601.91,YSKEYOLD,0)
39 ... S $P(^YTT(601.91,YSKEYNEW,0),U)=YSKEYNEW
40 ... S $P(^YTT(601.91,YSKEYNEW,0),U,2)=YSSLNEW
41 ... S YSQX=$P(^YTT(601.91,YSKEYNEW,0),U,3)
42 ... I (YSQX?1N.N)&($D(^TMP($J,"YSM","O",YSQX))) S $P(^YTT(601.91,YSKEYNEW,0),U,3)=^TMP($J,"YSM","O",YSQX)
43 ... S DA=YSKEYNEW,DIK="^YTT(601.91," D IX^DIK
44 Q
45RULES ;from copy
46 S N=$O(^YTT(601.83,"C",YSOLDNUM,N)) Q:N'>0 D
47 . S G1=^YTT(601.83,N,0)
48 . S YSISRNEW=$$NEW^YTQLIB(YSFILE)
49 . S ^YTT(601.83,YSISRNEW,0)=G1
50 . S $P(^YTT(601.83,YSISRNEW,0),U)=YSISRNEW
51 . S $P(^YTT(601.83,YSISRNEW,0),U,2)=YSNEWNUM
52 . S YSQX=$P(G1,U,3)
53 . I (YSQX?1N.N)&($D(^TMP($J,"YSM","O",YSQX))) S $P(^YTT(601.83,YSECNEW,0),U,3)=^TMP($J,"YSM","O",YSQX)
54 . S DA=YSISRNEW,DIK="^YTT("_YSFILE_"," D IX^DIK
55 . ;add rule
56 . S YSRULOLD=$P(G,U,4)
57 . S G2=^YTT(601.82,YSRULOLD,0)
58 . S YSRULNEW=$$NEW^YTQLIB(601.82)
59 . S $P(^YTT(601.83,YSISRNEW,0),U,4)=YSRULNEW
60 . S ^YTT(601.82,YSRULNEW,0)=G2
61 . S $P(^YTT(601.82,YSRULNEW,0),U)=YSRULNEW
62 . S YSQX=$P(G2,U,2)
63 . I (YSQX?1N.N)&($D(^TMP($J,"YSM","O",YSQX))) S $P(^YTT(601.82,YSRULNEW,0),U,2)=^TMP($J,"YSM","O",YSQX)
64 . S YSQX=$P(G2,U,7)
65 . I (YSQX?1N.N)&($D(^TMP($J,"YSM","O",YSQX))) S $P(^YTT(601.82,YSRULNEW,0),U,7)=^TMP($J,"YSM","O",YSQX)
66 . S DA=YSRULNEW,DIK="^YTT(601.82," D IX^DIK
67 Q
68FULLWP(YSDATA,YS) ;first line of all WPS
69 ;returns a WP field
70 ;Input: FILEN(file number), FIELD (WP filed #)
71 ;Ouput IEN^WP Text line N
72 N N,YSN,YSN1,YSFILEN,YSFIELD
73 S YSDATA=$NA(^TMP($J,"YSWP")) K ^TMP($J,"YSWP")
74 S YSFILEN=$G(YS("FILEN"),0) I $$VFILE^DILFD(YSFILEN)<1 S ^TMP($J,"YSWP",1)="[ERROR]",^TMP($J,"YSWP",2)="BAD FILE N" Q ;--->out
75 S YSFIELD=$G(YS("FIELD"),0) S N=$$VFIELD^DILFD(YSFILEN,YSFIELD) I N<1 S ^TMP($J,"YSWP",1)="[ERROR]",^TMP($J,"YSWP",2)="BAD field" Q ;--> out
76 S YSN=0,N=1,^TMP($J,"YSWP",1)="[DATA]"
77 F S YSN=$O(^YTT(YSFILEN,YSN)) Q:YSN'>0 D
78 . S YSN1=0 F S YSN1=$O(^YTT(YSFILEN,YSN,YSFIELD,YSN1)) Q:YSN1'>0 D
79 .. S N=N+1
80 .. S ^TMP($J,"YSWP",N)=YSN_U_$G(^YTT(YSFILEN,YSN,YSFIELD,YSN1,0))
81 Q
82FINDP(YSDATA,YS) ; patient lookup
83 ; input:
84 ; VALUE = value to lookup
85 ; NUMBER= maximum number to find
86 ; Lookup uses multiple index lookup of File #2
87 ; output:
88 ; [DATA]^number of records returned
89 ; DFN^patient name^DOB^PID^Gender
90 ;
91 N DIERR,YSVALUE,NODE,SSN,DSSN,PLID,YSN,YSX,YSNUMBER
92 S YSVALUE=$G(YS("VALUE"))
93 S YSNUMBER=$G(YS("NUMBER"),"*")
94 K ^TMP("YSDATA",$J) S YSDATA=$NA(^TMP("YSDATA",$J))
95 D FIND^DIC(2,,".01;.03;.363;.09;.02","PS",YSVALUE,YSNUMBER,"B^BS^BS5^SSN")
96 I $G(DIERR) D CLEAN^DILF Q
97 S YSN=1,^TMP("YSDATA",$J,YSN)="[DATA]"_U_+^TMP("DILIST",$J,0)
98 S YSX=0 F S YSX=$O(^TMP("DILIST",$J,YSX)) Q:YSX'>0 D
99 . S NODE=^TMP("DILIST",$J,YSX,0)
100 . ;Apply DOB screen
101 . S $P(NODE,U,3)=$$DOB^DPTLK1(+NODE)
102 . ;Apply SSN screen
103 . S SSN=$$SSN^DPTLK1(+NODE)
104 . S DSSN=$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,11)
105 . S PLID=$P(NODE,U,4)
106 . I $E(SSN,1,9)'?9N S (DSSN,PLID)=SSN
107 . S $P(NODE,U,4)=$S($L(PLID)>5:PLID,1:DSSN)
108 . ;Move screened data back into output global
109 . S YSN=YSN+1,^TMP("YSDATA",$J,YSN)=$P(NODE,U,1,4)_U_$P(NODE,U,6)
110 K ^TMP("DILIST",$J)
111 Q
Note: See TracBrowser for help on using the repository browser.