source: WorldVistAEHR/trunk/r/OCCURRENCE_SCREEN-QAO/QAOSDDUT.m@ 1742

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

initial load of WorldVistAEHR

File size: 2.1 KB
Line 
1QAOSDDUT ;HISC/DAD-OCCURRENCE SCREEN DD UTILITIES ;1/6/93 15:15
2 ;;3.0;Occurrence Screen;;09/14/1993
3EN1(OK) ; INPUT TRANSFORM FOR FREE TEXT 'SET OF CODES'
4 ; OK = NON-REPEATING, NON-NULL LIST OF VALID CODES
5 ; USED BY FIELDS: 741.6,2 & 741.7,1
6 I $TR(X,OK)]"" K X Q
7 F OK(0)=1:1:$L(X) I $L(X,$E(OK,OK(0)))>2 K X Q
8 Q
9EN2 ; XECUTABLE HELP FOR DATE PROMPTS
10 ; USED BY FIELDS: 741.01,1 & 741,14 & *741,18
11 Q:$D(QAOSD0)[0 N Y
12 S Y=$P(^QA(741,QAOSD0,0),"^",3)\1 X ^DD("DD")
13 W !?5,"Must be after the occurrence date: ",Y
14 S Y=DT X ^DD("DD") W !?5,"and not later than: ",Y,!
15 Q
16EN3 ; INPUT TRANSFORM FOR 'FINAL PEER REVIEW PER SERVICE'
17 ; ALLOWS ONLY PEER REVIEWERS AND ONLY ONE PEER REVIEWER
18 ; PER SERVICE TO ANSWER 'YES' USED BY FIELD: 741.01,9
19 Q:$D(QAOSD0)[0 Q:$D(QAOSD1)[0 N QA,QAOSSERV
20 I +^QA(741,QAOSD0,"REVR",QAOSD1,0)'=$O(^QA(741.2,"C",2,0)) W !!,"*** This field may only be edited by Peer reviewers ***" K X Q
21 Q:X'=1 S QAOSSERV=$P($G(^QA(741,QAOSD0,"REVR",QAOSD1,0)),"^",10),QA=0
22 F S QA=$O(^QA(741,QAOSD0,"REVR","AONLY1",1,QA)) Q:(QA'>0)!($D(X)[0) D
23 . I QA'=QAOSD1,$P($G(^QA(741,QAOSD0,"REVR",QA,0)),"^",10)=QAOSSERV D
24 .. W !!," *** Another Peer review has previously been entered as the final review ***",!
25 .. K X Q
26 . Q
27 Q
28EN4 ; INPUT TRANSFORM: REVIEWING SERVICE 741.01,.03
29 ; SERVICE IS UNEDITABLE IF FINAL PEER REVIEW PER SERVICE IS YES
30 Q:$D(QAOSD0)[0 Q:$D(QAOSD1)[0 N QA
31 S QA=$G(^QA(741,QAOSD0,"REVR",QAOSD1,0))
32 K:$P(QA,"^",9)&$P(QA,"^",10) X
33 Q
34EN5 ; SCREEN: REASON FOR EXCEPTION (741.12,.01)
35 I 1 Q:$D(QAOSD0)[0
36 N QA S QA=^QA(741.5,+Y,0)
37 I $P(QA,"^",4)'>0,$P(QA,"^",2)=+$G(^QA(741,QAOSD0,"SCRN"))
38 Q
39EN6 ; SCREEN: PRIMARY REASON CLIN REFERRAL (741.01,3)
40 I 1 Q:$D(QAOSD0)[0
41 I $P($G(^QA(741.4,+Y,1)),"^",2)=+$G(^QA(741,QAOSD0,"SCRN"))
42 Q
43EN7 ; SCREEN: ACTION (741.15,.01)
44 I 1 Q:$D(QAOSD0)[0 Q:$D(QAOSD1)[0
45 N QA S QA=+$G(^QA(741,QAOSD0,"REVR",QAOSD1,0))
46 S QA=$P($G(^QA(741.2,QA,0)),"^",2)
47 I QA]"",$P(^QA(741.7,+Y,0),"^",2)[QA
48 Q
49EN8 ; SCREEN: FINDINGS (741.01,4)
50 I 1 Q:$D(QAOSD0)[0 Q:$D(QAOSD1)[0
51 N QA S QA=+$G(^QA(741,QAOSD0,"REVR",QAOSD1,0))
52 S QA=+$P($G(^QA(741.2,QA,0)),"^",2)
53 I $P(^QA(741.6,+Y,0),"^",3)[QA
54 Q
Note: See TracBrowser for help on using the repository browser.