QAOSLAPS ;HISC/JES,DAD-COMPUTE ELAPSED DAYS ;7/26/93 12:20
;;3.0;Occurrence Screen;;09/14/1993
ENLAPSE ; ELAPSED DAYS FOR CLINICAL, PEER, AND MANAGEMENT REVIEWS
N QAQADICT,QAQAFLD,QAQAXREF
S (QAQAX,X1)=X,X2=$P(^QA(741,DA(1),0),"^",3)
I X1>0,X2>0 D
. D ^%DTC S $P(^QA(741,DA(1),"REVR",DA,0),"^",8)=X
. S QAQADICT=741.01,QAQAFLD=8 D ENSET^QAQAXREF
. Q
S X=QAQAX G EXIT
ENLAPSO ; ELAPSED DAYS CALCULATED FROM THE OCCURRENCE DATE XREF
S QAQAX=X N QAQADICT,QAQAFLD,QAQAXREF
F IEN=0:0 S IEN=$O(^QA(741,DA,"REVR",IEN)) Q:IEN'>0 D O
S X=QAQAX G EXIT
O S QAQA=^QA(741,DA,"REVR",IEN,0)
S X=$P(QAQA,"^",8),QAQADICT=741.01,QAQAFLD=8 D ENKILL^QAQAXREF
S $P(^QA(741,DA,"REVR",IEN,0),"^",8)=""
S X1=$P(QAQA,"^",3),X2=QAQAX
I X1>0,X2>0 D
. D ^%DTC S $P(^QA(741,DA,"REVR",IEN,0),"^",8)=X
. S QAQADICT=741.01,QAQAFLD=8 D ENSET^QAQAXREF
. Q
Q
ENDUES ; DUE DATES FOR PEER AND MANAGER
S QA(0)=$O(^QA(741.2,"C",1,0))
Q:QA(0)'=+^QA(741,DA(1),"REVR",DA,0) Q:$D(^QA(740,1,"OS"))[0
S QA=X,QA("DA")=DA,DA=DA(1)
F QA(0)=1:1:2 S X2=$P(^QA(740,1,"OS"),"^",QA(0)) I X2>0 D
. S X1=QA D C^%DTC S X=X\1 S $P(^QA(741,DA,0),"^",11+QA(0))=X
. N QAQAXREF,QAQADICT,QAQAFLD
. S QAQADICT=741,QAQAFLD=11+QA(0) D ENSET^QAQAXREF
. Q
S DA=QA("DA")
EXIT ;
K QA,QACL,QAL,QA1,QAPEER,QAMANG,QASKIP,QASKIM,QAPIECE,QAQAX,X,X1,X2
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAOSLAPS 1349 printed Dec 13, 2024@02:21:32 Page 2
QAOSLAPS ;HISC/JES,DAD-COMPUTE ELAPSED DAYS ;7/26/93 12:20
+1 ;;3.0;Occurrence Screen;;09/14/1993
ENLAPSE ; ELAPSED DAYS FOR CLINICAL, PEER, AND MANAGEMENT REVIEWS
+1 NEW QAQADICT,QAQAFLD,QAQAXREF
+2 SET (QAQAX,X1)=X
SET X2=$PIECE(^QA(741,DA(1),0),"^",3)
+3 IF X1>0
IF X2>0
Begin DoDot:1
+4 DO ^%DTC
SET $PIECE(^QA(741,DA(1),"REVR",DA,0),"^",8)=X
+5 SET QAQADICT=741.01
SET QAQAFLD=8
DO ENSET^QAQAXREF
+6 QUIT
End DoDot:1
+7 SET X=QAQAX
GOTO EXIT
ENLAPSO ; ELAPSED DAYS CALCULATED FROM THE OCCURRENCE DATE XREF
+1 SET QAQAX=X
NEW QAQADICT,QAQAFLD,QAQAXREF
+2 FOR IEN=0:0
SET IEN=$ORDER(^QA(741,DA,"REVR",IEN))
if IEN'>0
QUIT
DO O
+3 SET X=QAQAX
GOTO EXIT
O SET QAQA=^QA(741,DA,"REVR",IEN,0)
+1 SET X=$PIECE(QAQA,"^",8)
SET QAQADICT=741.01
SET QAQAFLD=8
DO ENKILL^QAQAXREF
+2 SET $PIECE(^QA(741,DA,"REVR",IEN,0),"^",8)=""
+3 SET X1=$PIECE(QAQA,"^",3)
SET X2=QAQAX
+4 IF X1>0
IF X2>0
Begin DoDot:1
+5 DO ^%DTC
SET $PIECE(^QA(741,DA,"REVR",IEN,0),"^",8)=X
+6 SET QAQADICT=741.01
SET QAQAFLD=8
DO ENSET^QAQAXREF
+7 QUIT
End DoDot:1
+8 QUIT
ENDUES ; DUE DATES FOR PEER AND MANAGER
+1 SET QA(0)=$ORDER(^QA(741.2,"C",1,0))
+2 if QA(0)'=+^QA(741,DA(1),"REVR",DA,0)
QUIT
if $DATA(^QA(740,1,"OS"))[0
QUIT
+3 SET QA=X
SET QA("DA")=DA
SET DA=DA(1)
+4 FOR QA(0)=1:1:2
SET X2=$PIECE(^QA(740,1,"OS"),"^",QA(0))
IF X2>0
Begin DoDot:1
+5 SET X1=QA
DO C^%DTC
SET X=X\1
SET $PIECE(^QA(741,DA,0),"^",11+QA(0))=X
+6 NEW QAQAXREF,QAQADICT,QAQAFLD
+7 SET QAQADICT=741
SET QAQAFLD=11+QA(0)
DO ENSET^QAQAXREF
+8 QUIT
End DoDot:1
+9 SET DA=QA("DA")
EXIT ;
+1 KILL QA,QACL,QAL,QA1,QAPEER,QAMANG,QASKIP,QASKIM,QAPIECE,QAQAX,X,X1,X2
+2 QUIT
