55 lines
2.1 KiB
Mathematica
55 lines
2.1 KiB
Mathematica
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
|