QAOSDDUT ;HISC/DAD-OCCURRENCE SCREEN DD UTILITIES ;1/6/93  15:15
 ;;3.0;Occurrence Screen;;09/14/1993
EN1(OK) ; INPUT TRANSFORM FOR FREE TEXT 'SET OF CODES'
 ; OK = NON-REPEATING, NON-NULL LIST OF VALID CODES
 ; USED BY FIELDS: 741.6,2 & 741.7,1
 I $TR(X,OK)]"" K X Q
 F OK(0)=1:1:$L(X) I $L(X,$E(OK,OK(0)))>2 K X Q
 Q
EN2 ; XECUTABLE HELP FOR DATE PROMPTS
 ; USED BY FIELDS: 741.01,1 & 741,14 & *741,18
 Q:$D(QAOSD0)[0  N Y
 S Y=$P(^QA(741,QAOSD0,0),"^",3)\1 X ^DD("DD")
 W !?5,"Must be after the occurrence date: ",Y
 S Y=DT X ^DD("DD") W !?5,"and not later than: ",Y,!
 Q
EN3 ; INPUT TRANSFORM FOR 'FINAL PEER REVIEW PER SERVICE'
 ; ALLOWS ONLY PEER REVIEWERS AND ONLY ONE PEER REVIEWER
 ; PER SERVICE TO ANSWER 'YES' USED BY FIELD: 741.01,9
 Q:$D(QAOSD0)[0  Q:$D(QAOSD1)[0  N QA,QAOSSERV
 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
 Q:X'=1  S QAOSSERV=$P($G(^QA(741,QAOSD0,"REVR",QAOSD1,0)),"^",10),QA=0
 F  S QA=$O(^QA(741,QAOSD0,"REVR","AONLY1",1,QA)) Q:(QA'>0)!($D(X)[0)  D
 . I QA'=QAOSD1,$P($G(^QA(741,QAOSD0,"REVR",QA,0)),"^",10)=QAOSSERV D
 .. W !!,"  *** Another Peer review has previously been entered as the final review ***",!
 .. K X Q
 . Q
 Q
EN4 ; INPUT TRANSFORM: REVIEWING SERVICE 741.01,.03
 ; SERVICE IS UNEDITABLE IF FINAL PEER REVIEW PER SERVICE IS YES
 Q:$D(QAOSD0)[0  Q:$D(QAOSD1)[0  N QA
 S QA=$G(^QA(741,QAOSD0,"REVR",QAOSD1,0))
 K:$P(QA,"^",9)&$P(QA,"^",10) X
 Q
EN5 ; SCREEN: REASON FOR EXCEPTION (741.12,.01)
 I 1 Q:$D(QAOSD0)[0
 N QA S QA=^QA(741.5,+Y,0)
 I $P(QA,"^",4)'>0,$P(QA,"^",2)=+$G(^QA(741,QAOSD0,"SCRN"))
 Q
EN6 ; SCREEN: PRIMARY REASON CLIN REFERRAL (741.01,3)
 I 1 Q:$D(QAOSD0)[0
 I $P($G(^QA(741.4,+Y,1)),"^",2)=+$G(^QA(741,QAOSD0,"SCRN"))
 Q
EN7 ; SCREEN: ACTION (741.15,.01)
 I 1 Q:$D(QAOSD0)[0  Q:$D(QAOSD1)[0
 N QA S QA=+$G(^QA(741,QAOSD0,"REVR",QAOSD1,0))
 S QA=$P($G(^QA(741.2,QA,0)),"^",2)
 I QA]"",$P(^QA(741.7,+Y,0),"^",2)[QA
 Q
EN8 ; SCREEN: FINDINGS (741.01,4)
 I 1 Q:$D(QAOSD0)[0  Q:$D(QAOSD1)[0
 N QA S QA=+$G(^QA(741,QAOSD0,"REVR",QAOSD1,0))
 S QA=+$P($G(^QA(741.2,QA,0)),"^",2)
 I $P(^QA(741.6,+Y,0),"^",3)[QA
 Q