source: WorldVistAEHR/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTAPI7.m@ 724

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

initial load of WorldVistAEHR
File size: 3.5 KB
Line 
1YTAPI7 ;ASF/ALB- PSYCH TEST API INCOMPLETES ;5/9/01 16:55
2 ;;5.01;MENTAL HEALTH;**71**;Dec 30, 1994
3SAVEINC(YSDATA,YS) ; save incomplete admins
4 N B,R1,R2,R3,DA,DIK,YSNEXT,X,Y,N1,YSADATE,DFN,YSCODE,YSNEXT,YSORDER
5 D PARSE(.YS)
6 I '$D(DFN) S YSDATA(1)="[ERROR]",YSDATA(2)="no pt dfn" Q ;--->OUT
7 I '$D(YSNEXT) S YSDATA(1)="[ERROR]",YSDATA(2)="no next" Q ;---> OUT
8 I YSCODE=""!'$D(^YTT(601,YSCODE)) S YSDATA(1)="[ERROR]",YSADTA(2)="bad test code" Q ;--->OUT
9 I YSORDER'?1N.N S YSDATA(1)="[ERROR]",YSADTA(2)="bad ORDERED BY" Q ;--->OUT
10SAV1 ;
11 L +^YTD(601.4,DFN):0 Q:'$T
12 I '$D(^YTD(601.4,DFN,0)) D NEWPT ;add at dfn level
13 S $P(^YTD(601.4,DFN,1,0),U,2)="601.4P"
14 S:YSCODE>$P(^YTD(601.4,DFN,1,0),U,3) $P(^YTD(601.4,DFN,1,0),U,3)=YSCODE
15 S $P(^YTD(601.4,DFN,1,0),U,4)=$P(^YTD(601.4,DFN,1,0),U,4)+1
16 S ^YTD(601.4,DFN,1,YSCODE,0)=YSCODE_"^"_YSADATE_"^^"_YSNEXT_"^"_$P($G(^YTT(601,YSCODE,"Q",YSNEXT,0)),U,2)_"^^"_YSORDER
17 S:$P(^YTD(601.4,DFN,1,YSCODE,0),U,8)="" $P(^YTD(601.4,DFN,1,YSCODE,0),U,8)=DT
18 S B="",N1=YSNEXT+.1 ;bottom text
19 F S N1=$O(^YTT(601,YSCODE,"Q",N1),-1) Q:N1'>0 S B=$G(^YTT(601,YSCODE,"Q",N1,"B")) Q:$D(^YTT(601,YSCODE,"Q",N1,"B"))
20 I $L(B) S ^YTD(601.4,DFN,1,YSCODE,"B")=B
21 S ^YTD(601.4,DFN,1,YSCODE,1)=R1
22 S ^YTD(601.4,DFN,1,YSCODE,2)=R2
23 S ^YTD(601.4,DFN,1,YSCODE,3)=R3
24 S DIK="^YTD(601.4,",DA=DFN D IX^DIK ;reindex
25 L -^YTD(601.4,DFN)
26 S YSDATA(1)="[DATA]",YSDATA(2)="saved ok"
27 Q
28NEWPT ;new entry to 601.4
29 L +^YTD(601.4,0):0 Q:'$T
30 S X=^YTD(601.4,0),X(4)=$P(X,U,4),X(3)=$P(X,U,3),X(4)=X(4)+1
31 S:DFN>X(3) X(3)=DFN
32 S X=$P(X,U,1,2)_"^"_X(3)_"^"_X(4)
33 S ^YTD(601.4,0)=X,^YTD(601.4,DFN,0)=DFN,^YTD(601.4,"B",DFN,DFN)=""
34 L -^YTD(601.4,0)
35 Q
36LISTINC(YSDATA,YS) ;list all incompletes for a pt
37 N DFN,YSCODE,YSCODEN,X,Y,N,N1,G,YSL,YSADATE,YTLM,YSRSLMT
38 S YSRSLMT=$P($G(^YSA(602,1,0)),U,3)
39 S DFN=$G(YS("DFN"))
40 I '$D(DFN) S YSDATA(1)="[ERROR]",YSDATA(2)="no pt dfn" Q ;--->OUT
41 S YSDATA(1)="[DATA]"
42 S N1=0 F S N1=$O(^YTD(601.4,DFN,1,N1)) Q:N1'>0 D
43 . S G=^YTD(601.4,DFN,1,N1,0)
44 . S YSCODE=N1,YSCODEN=$P($G(^YTT(601,N1,0)),U)
45 . S:YSCODEN?1"CLERK".E YSCODE=$P(G,U,6) S:YSCODE>0 YSCODEN=$P(^YTT(601,YSCODE,0),U)
46 . Q:$P(^YTT(601,YSCODE,0),U,9)'="T" ;--> OUT ASF 4/27/01
47 . S YSL(YSCODEN)=YSCODEN
48 . S (YSADATE,Y)=$P(G,U,2) D DD^%DT S $P(YSL(YSCODEN),U,2)=Y
49 . S YTLM=YSRSLMT
50 . I $P($G(^YTT(601,YSCODE,0)),U,16) S YTLM=$P(^(0),U,16)
51 . S X=$$FMDIFF^XLFDT(DT,YSADATE,1)
52 . S $P(YSL(YSCODEN),U,3)=$S(X>YTLM:"not restartable",1:"restartable")
53 S N1=0,N=0 F S N1=$O(YSL(N1)) Q:N1="" D
54 . S N=N+1
55 . S YSDATA(N)=YSL(N1)
56 Q
57GETINC(YSDATA,YS) ;get saved data
58 N DFN,YSCODE,YSCLERK,YSCLERKN,YSENT
59 D PARSE(.YS)
60 I '$D(DFN) S YSDATA(1)="[ERROR]",YSDATA(2)="no pt dfn" Q ;--->OUT
61 I YSCODE=""!'$D(^YTT(601,YSCODE)) S YSDATA(1)="[ERROR]",YSADTA(2)="bad test code" Q ;--->OUT
62 I '$D(^YTD(601.4,DFN)) S YSDATA(1)="[ERROR]",YSDATA(2)="no inc for dfn" Q ;--> OUT
63 S YSCLERK=$O(^YTT(601,"B","CLERK",0))
64 S YSCLERKN=$P($G(^YTD(601.4,DFN,1,YSCLERK,0)),U,6)
65 I '$D(^YTD(601.4,DFN,1,YSCODE))&(YSCODE'=YSCLERKN) S YSDATA(1)="[ERROR]",YSDATA(2)="no data for test" Q ;-->OUT
66 S YSENT=$S(YSCODE=YSCLERKN:YSCLERK,1:YSCODE)
67 S YSDATA(1)="[DATA]"
68 S YSDATA(2)=^YTD(601.4,DFN,1,YSENT,0)
69 S YSDATA(3)=$G(^YTD(601.4,DFN,1,YSENT,1))
70 S YSDATA(4)=$G(^YTD(601.4,DFN,1,YSENT,2))
71 S YSDATA(5)=$G(^YTD(601.4,DFN,1,YSENT,3))
72 Q
73PARSE(YS) ; -- array parsing
74 S DFN=$G(YS("DFN"))
75 S YSCODE=$G(YS("CODE"),"ERROR")
76 S:YSCODE'?1N.N YSCODE=$O(^YTT(601,"B",YSCODE,0))
77 S YSADATE=$G(YS("ADATE")) S X=YSADATE D ^%DT S YSADATE=Y
78 S YSORDER=$G(YS("ORDERBY"))
79 S YSNEXT=$G(YS("NEXT"))
80 S R1=$G(YS("R1"))
81 S R2=$G(YS("R2"))
82 S R3=$G(YS("R3"))
83 Q
Note: See TracBrowser for help on using the repository browser.