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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAOSDDUT 2212 printed Nov 22, 2024@17:31:25 Page 2
QAOSDDUT ;HISC/DAD-OCCURRENCE SCREEN DD UTILITIES ;1/6/93 15:15
+1 ;;3.0;Occurrence Screen;;09/14/1993
EN1(OK) ; INPUT TRANSFORM FOR FREE TEXT 'SET OF CODES'
+1 ; OK = NON-REPEATING, NON-NULL LIST OF VALID CODES
+2 ; USED BY FIELDS: 741.6,2 & 741.7,1
+3 IF $TRANSLATE(X,OK)]""
KILL X
QUIT
+4 FOR OK(0)=1:1:$LENGTH(X)
IF $LENGTH(X,$EXTRACT(OK,OK(0)))>2
KILL X
QUIT
+5 QUIT
EN2 ; XECUTABLE HELP FOR DATE PROMPTS
+1 ; USED BY FIELDS: 741.01,1 & 741,14 & *741,18
+2 if $DATA(QAOSD0)[0
QUIT
NEW Y
+3 SET Y=$PIECE(^QA(741,QAOSD0,0),"^",3)\1
XECUTE ^DD("DD")
+4 WRITE !?5,"Must be after the occurrence date: ",Y
+5 SET Y=DT
XECUTE ^DD("DD")
WRITE !?5,"and not later than: ",Y,!
+6 QUIT
EN3 ; INPUT TRANSFORM FOR 'FINAL PEER REVIEW PER SERVICE'
+1 ; ALLOWS ONLY PEER REVIEWERS AND ONLY ONE PEER REVIEWER
+2 ; PER SERVICE TO ANSWER 'YES' USED BY FIELD: 741.01,9
+3 if $DATA(QAOSD0)[0
QUIT
if $DATA(QAOSD1)[0
QUIT
NEW QA,QAOSSERV
+4 IF +^QA(741,QAOSD0,"REVR",QAOSD1,0)'=$ORDER(^QA(741.2,"C",2,0))
WRITE !!,"*** This field may only be edited by Peer reviewers ***"
KILL X
QUIT
+5 if X'=1
QUIT
SET QAOSSERV=$PIECE($GET(^QA(741,QAOSD0,"REVR",QAOSD1,0)),"^",10)
SET QA=0
+6 FOR
SET QA=$ORDER(^QA(741,QAOSD0,"REVR","AONLY1",1,QA))
if (QA'>0)!($DATA(X)[0)
QUIT
Begin DoDot:1
+7 IF QA'=QAOSD1
IF $PIECE($GET(^QA(741,QAOSD0,"REVR",QA,0)),"^",10)=QAOSSERV
Begin DoDot:2
+8 WRITE !!," *** Another Peer review has previously been entered as the final review ***",!
+9 KILL X
QUIT
End DoDot:2
+10 QUIT
End DoDot:1
+11 QUIT
EN4 ; INPUT TRANSFORM: REVIEWING SERVICE 741.01,.03
+1 ; SERVICE IS UNEDITABLE IF FINAL PEER REVIEW PER SERVICE IS YES
+2 if $DATA(QAOSD0)[0
QUIT
if $DATA(QAOSD1)[0
QUIT
NEW QA
+3 SET QA=$GET(^QA(741,QAOSD0,"REVR",QAOSD1,0))
+4 if $PIECE(QA,"^",9)&$PIECE(QA,"^",10)
KILL X
+5 QUIT
EN5 ; SCREEN: REASON FOR EXCEPTION (741.12,.01)
+1 IF 1
if $DATA(QAOSD0)[0
QUIT
+2 NEW QA
SET QA=^QA(741.5,+Y,0)
+3 IF $PIECE(QA,"^",4)'>0
IF $PIECE(QA,"^",2)=+$GET(^QA(741,QAOSD0,"SCRN"))
+4 QUIT
EN6 ; SCREEN: PRIMARY REASON CLIN REFERRAL (741.01,3)
+1 IF 1
if $DATA(QAOSD0)[0
QUIT
+2 IF $PIECE($GET(^QA(741.4,+Y,1)),"^",2)=+$GET(^QA(741,QAOSD0,"SCRN"))
+3 QUIT
EN7 ; SCREEN: ACTION (741.15,.01)
+1 IF 1
if $DATA(QAOSD0)[0
QUIT
if $DATA(QAOSD1)[0
QUIT
+2 NEW QA
SET QA=+$GET(^QA(741,QAOSD0,"REVR",QAOSD1,0))
+3 SET QA=$PIECE($GET(^QA(741.2,QA,0)),"^",2)
+4 IF QA]""
IF $PIECE(^QA(741.7,+Y,0),"^",2)[QA
+5 QUIT
EN8 ; SCREEN: FINDINGS (741.01,4)
+1 IF 1
if $DATA(QAOSD0)[0
QUIT
if $DATA(QAOSD1)[0
QUIT
+2 NEW QA
SET QA=+$GET(^QA(741,QAOSD0,"REVR",QAOSD1,0))
+3 SET QA=+$PIECE($GET(^QA(741.2,QA,0)),"^",2)
+4 IF $PIECE(^QA(741.6,+Y,0),"^",3)[QA
+5 QUIT
