source: WorldVistAEHR/trunk/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBABFRM.m@ 771

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

initial load of WorldVistAEHR
File size: 4.7 KB
Line 
1DVBABFRM ;ALB/SPH - CAPRI TEMPLATE/WORKSHEETS UTILITIES ;11/17/02
2 ;;2.7;AMIE;**53,57,90**;Apr 10, 1995
3 ;
4DEFINE(Y,DVBIEN,DVBTYPE) ;
5 ; DVBTYPE: 1= Form Definition, 2=Script, 3=Report
6 N DVBJ K ^TMP($J,"AMIE")
7 S DVBJ=0,DVBTYPE=DVBTYPE+2,Y=$NA(^TMP($J,"AMIE"))
8 F S DVBJ=$O(^DVB(396.18,DVBIEN,DVBTYPE,DVBJ)) Q:'DVBJ D
9 .S ^TMP($J,"AMIE",DVBJ)=$G(^DVB(396.18,DVBIEN,DVBTYPE,DVBJ,0))_$C(13)
10 Q
11UPDATE(Y,DVBIEN,DVBTYPE,DVBLINES,DVBLINEC,DVBLINEB) ;
12 ; DVBTYPE: 1= Form Definition, 2=Script, 3=Report
13 N DVBNUM,DVBCOUNT
14 I DVBTYPE=1,DVBLINEB=0 D
15 .K ^DVB(396.18,DVBIEN,3)
16 .S ^DVB(396.18,DVBIEN,3,0)=DVBLINES(1)
17 S DVBNUM=DVBLINEB,DVBCOUNT=1,DVBTYPE=DVBTYPE+2
18 I DVBLINEB=0 S DVBCOUNT=2
19 I DVBNUM>0 S DVBNUM=DVBNUM-1
20 F S DVBNUM=DVBNUM+1 Q:DVBNUM=(DVBLINEC+DVBLINEB) D
21 .S ^DVB(396.18,DVBIEN,DVBTYPE,DVBNUM,0)=DVBLINES(DVBCOUNT),DVBCOUNT=DVBCOUNT+1
22 Q
23SAVE(Y,DVBIEN,DVBLINES,DVBLINEC,DVBLINEB,DVBTPSV) ;
24 ; DVBTPSV: 3/NULL=NORMAL GLOBAL
25 N DVBNUM,DVBCOUNT
26 S DVBTPSV=$G(DVBTPSV,3),DVBNUM=DVBLINEB,DVBCOUNT=1
27 I DVBLINEB=0 D
28 .K ^DVB(396.17,DVBIEN,DVBTPSV)
29 .S ^DVB(396.17,DVBIEN,DVBTPSV,0)=DVBLINES(1),DVBCOUNT=2
30 I DVBNUM>0 S DVBNUM=DVBNUM-1
31 F S DVBNUM=DVBNUM+1 Q:DVBNUM=(DVBLINEC+DVBLINEB) D
32 .S ^DVB(396.17,DVBIEN,DVBTPSV,DVBNUM,0)=DVBLINES(DVBCOUNT),DVBCOUNT=DVBCOUNT+1
33 ; SET Y TO NUMBER OF LINES IN THE GLOBAL FOR GUI VERIFICATION
34 S Y=+$P($G(^DVB(396.17,DVBIEN,DVBTPSV,0)),U,3)
35 Q
36LOAD(Y,DVBIEN,DVBTPSV) ;
37 ; DVBTPSV: 3/NULL=NORMAL GLOBAL
38 N DVBABCNT,DVBABIEN K ^TMP("DVBAFRML",DUZ)
39 S DVBTPSV=$G(DVBTPSV,3),DVBABCNT=1,DVBABIEN=0,Y=$NA(^TMP("DVBAFRML",DUZ))
40 F S DVBABIEN=$O(^DVB(396.17,DVBIEN,DVBTPSV,DVBABIEN)) Q:'DVBABIEN D
41 .S ^TMP("DVBAFRML",DUZ,DVBABCNT-1)=$G(^DVB(396.17,DVBIEN,DVBTPSV,DVBABCNT,0))_$C(13),DVBABCNT=DVBABCNT+1
42 Q
43CCOW(Y,F) ;RPC DVBAB CCOW
44 S Y=-1
45 S:F=1 Y=$$SITE^VASITE
46 S:F=2 Y=$$PROD^XUPROD
47 Q
48U1N4(Y,ARR) ;RPC DVBAB FETCH 1U4N
49 N I,X S I="",Y=$NA(^TMP("DVBU1N4",$J)) K @Y
50 F S I=$O(ARR(I)) Q:I="" D
51 .S X=$P($G(^DVB(396.17,ARR(I),0)),U)
52 .S:X X=$$GET1^DIQ(2,X_",",.0905)
53 .S ^TMP("DVBU1N4",$J,I)=ARR(I)_U_$S(X]"":X,1:"?????")
54 Q
55DELETE(Y,IEN) ;RPC DVBAB FORM DATA BACKUP DELETE
56 S IEN=$G(IEN),Y=$S(IEN?1.N:0,1:"1^INVALID ARGUMENT")
57 I 'Y,'$D(^DVB(396.17,IEN,0)) S Y="1^RECORD NOT FOUND"
58 K:'Y&$D(^DVB(396.17,IEN,9)) ^DVB(396.17,IEN,9)
59 Q
60BACKUP(Y,IEN,TXT) ;RPC DVBAB FORM DATA BACKUP
61 N F,S,A,N,M,R S F=396.17,M="-1^RECORD NOT FOUND",IEN=$G(IEN)_","
62 S R="^DVB("_F_","_IEN,Y=$S(IEN?1.N1",":0,1:"-1^INVALID ARGUMENT")
63 I 'Y,'$D(@(R_"0)")) S Y=M
64 Q:Y S M=$P($G(@(R_"3,0)")),U,3) Q:'M
65 S S=396.19,N="+1,"_IEN,TXT=$G(TXT)
66 S A(S,N,.01)=$$NOW^XLFDT
67 S A(S,N,2)=$S(TXT]"":TXT,1:"Automatic Save by "_$P($G(^VA(200,DUZ,0)),U))
68 D UPDATE^DIE(,"A"),ERR(.Y)
69 I 'Y D
70 .S N=$P($G(@(R_"9,0)")),U,3)_","_IEN
71 .D WP^DIE(S,N,1,"A",R_"3)"),ERR(.Y)
72 .D:'Y WP^DIE(S,N,3,"A",R_"1)"),ERR(.Y)
73 S:'Y Y=M
74 Q
75RESTORE(Y,IEN,SN) ;RPC DVBAB FORM DATA BACKUP RESTORE
76 N Z,F,T,M,N,R S IEN=$G(IEN)_",",SN=$G(SN),N=396.17,R="^DVB("_N_","_IEN
77 S Y=$S(IEN?1.N1","&(SN?1.N):0,1:"-1^INVALID ARGUMENT")
78 S M="-1^RECORD NOT FOUND",SN=R_"9,"_SN_",",F="RESTORE "
79 I 'Y,'$D(@(R_"0)")) S Y=M
80 I 'Y,'$D(@(R_"9,0)")) S $P(M,U,2)="SUB-"_$P(M,U,2),Y=M
81 I 'Y,'$D(@(SN_"0)")) S $P(M,U,2)=F_$P(M,U,2),Y=M
82 Q:Y S M=$P($G(@(SN_"1,0)")),U,3),F=F_"FAILED: " Q:'M
83 M Z=@(R_"3)") K @(R_"3)")
84 D WP^DIE(N,IEN,8,"A",SN_"1)"),ERR(.Y)
85 I Y K @(R_"3)") M @(R_"3)")=Z S $P(Y,U,2)=F_$P(Y,U,2) Q
86 M T=@(R_"1)") K @(R_"1)")
87 D WP^DIE(N,IEN,6,"A",SN_"3)"),ERR(.Y) I 'Y S Y=M Q
88 K @(R_"3)"),@(R_"1)") M @(R_"3)")=Z,@(R_"1)")=T S $P(Y,U,2)=F_$P(Y,U,2)
89 Q
90COPY(Y,DA,DFN) ;RPC DVBAB FORM COPY
91 N F,A,P,N,M,R S DA=$G(DA)_",",F=396.17,R="^DVB("_F_","_DA
92 S N=" NOT FOUND",M="-1^RECORD"_N,DFN=$G(DFN,$P($G(@(R_"0)")),U))
93 S Y=$S(DA?1.N1",":0,1:"-1^INVALID ARGUMENT")
94 I 'Y,'$D(@(R_"0)")) S Y=M
95 I 'Y,'$D(^DPT(DFN,0)) S Y="-1^PATIENT"_N
96 S:'Y Y=$$AF(R) Q:Y
97 S P="+1,",A(F,P,.01)=DFN,A(F,P,2)=DUZ,A(F,P,11)="D"
98 S N=$$NOW^XLFDT,A(F,P,3)=N,A(F,P,4)=N
99 S A(F,P,9)=$P($G(@(R_"4)")),U),A(F,P,5)=2800101
100 D UPDATE^DIE(,"A"),ERR(.Y)
101 S DA=$P(@($P(R,",")_",0)"),U,3)
102 D:'Y WP^DIE(F,DA_",",6,"A",R_"1)"),ERR(.Y),DEL(Y,DA,F)
103 D:'Y WP^DIE(F,DA_",",8,"A",R_"3)"),ERR(.Y),DEL(Y,DA,F)
104 S:'Y Y=DA
105 Q
106DEL(Y,DA,F,DIK) Q:'Y S DIK=$G(DIK,^DIC(F,0,"GL")) D ^DIK Q
107AF(R) N C,I,J,K,L,N,X,Z S (I,C)=0,R=R_"1,",L=""
108 F S I=$O(@(R_I_")")) Q:'I D
109 .S K=$G(@(R_I_",0)")),N=$P(K,U,2),(Z,J)=0,K=+K
110 .S:K J=$G(^DVB(396.18,K,2)),X=$P(J,U,2),Z=DT<+J!(X'>DT&X)
111 .I Z!'K!'J S C=C+1 S:C>1 L=L_"; " S L=L_$S(N]"":N,1:$G(^DVB(396.18,K,0)))
112 Q:'C 0
113 Q "-1^Can't copy because th"_$S(C=1:"is form is",1:"ese forms are")_"n't active: "_L
114ERR(M) N D,I,K,X S M=0,D="DIERR" Q:'$D(^TMP(D,$J))
115 S M=$O(^TMP(D,$J,"E","")),I=$O(^(M,"")),X=","
116 F K=0:1 S K=$O(^TMP(D,$J,I,"TEXT",K)) Q:'K S X=X_" "_^(K)
117 S M="-1^Error "_M_X K ^TMP(D,$J)
118 Q
Note: See TracBrowser for help on using the repository browser.