| [613] | 1 | QAOSDDUT ;HISC/DAD-OCCURRENCE SCREEN DD UTILITIES ;1/6/93 15:15
|
|---|
| 2 | ;;3.0;Occurrence Screen;;09/14/1993
|
|---|
| 3 | EN1(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
|
|---|
| 9 | EN2 ; 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
|
|---|
| 16 | EN3 ; 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
|
|---|
| 28 | EN4 ; 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
|
|---|
| 34 | EN5 ; 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
|
|---|
| 39 | EN6 ; 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
|
|---|
| 43 | EN7 ; 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
|
|---|
| 49 | EN8 ; 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
|
|---|
