QAOSPAD0 ;HISC/DAD-ADVERSE FINDINGS REPORT ;6/11/93 15:54
;;3.0;Occurrence Screen;;09/14/1993
W !!,"Do you want the report to include the (N)ames/(C)odes of the ATTENDING PHYSICIAN",!,"RESIDENT/PROVIDER, MEDICAL TEAM, and ATTRIBUTIONs, or none (X) of the above?",!
ASK R !,"CHOOSE (N/C/X): N// ",X:DTIME S:'$T X="^" S:X="" X="N" S X=$E(X) G:X="^" EXIT S:X?1L X=$C($A(X)-32) S QAOSCHOS=X
I (X'="N")&(X'="C")&(X'="X") W:X'="?" " ??",*7 W !!?3,"Enter 'N' to get Names",!?3," 'C' to get Codes",!?3," 'X' to print neither names or codes",! G ASK
D ^QAQDATE G:QAQQUIT EXIT
K %ZIS S %ZIS="QM" D ^%ZIS G:POP EXIT I $D(IO("Q")) S ZTDESC="Adverse findings report",ZTRTN="ENTSK^QAOSPAD0",ZTSAVE("QAOS*")="",ZTSAVE("QAQ*")="" D ^%ZTLOAD G EXIT
ENTSK ;
K ^TMP($J,"A") S QAOSCLIN=+$O(^QA(741.2,"C",1,0)),QAOSPEER=+$O(^QA(741.2,"C",2,0)),QAOSEXCP=+$O(^QA(741.6,"B",3,0))
F QAOSDT=QAQNBEG-.0000001:0 S QAOSDT=$O(^QA(741,"C",QAOSDT)) Q:(QAOSDT'>0)!(QAOSDT>QAQNEND) F QAOSD0=0:0 S QAOSD0=$O(^QA(741,"C",QAOSDT,QAOSD0)) Q:QAOSD0'>0 D LOOP1
U IO D ^QAOSPAD1
EXIT ;
W ! D ^%ZISC
K %ZIS,ATTEND,DATE,DI,DH,DM,FIND,LOC,PAGE,PAT,POP,PROV,PT,QAOSCHOS,QAOSD0,QAOSDT,QAOSQUIT,QAOSZERO,SCRN,SERV,SRV,SSN,STATUS,TEAM,TODAY,UNDL,X,Y,ZTDESC,ZTRTN,ZTSAVE,%DT,D,I,Y,Z,QAOSCLIN,QAOSEXCP,QAOSD1,QAOSPEER
D K^QAQDATE S:$D(ZTQUEUED) ZTREQ="@"
Q
LOOP1 ;
S QAOSZERO=^QA(741,QAOSD0,0),SCRN=+$G(^("SCRN")),STATUS=+$P(QAOSZERO,"^",11) Q:(STATUS=2)!(SCRN'>0)
S Y=+$O(^QA(741,QAOSD0,"REVR","B",QAOSCLIN,0)) Q:QAOSEXCP=+$P($G(^QA(741,QAOSD0,"REVR",Y,0)),"^",5)
K FIND S (FIND(12),FIND(13))=0
F QAOSD1=0:0 S QAOSD1=$O(^QA(741,QAOSD0,"REVR","B",QAOSPEER,QAOSD1)) Q:QAOSD1'>0 D
. S X=$G(^QA(741,QAOSD0,"REVR",QAOSD1,0)) Q:$P(X,"^",9)'>0
. S FIND=+$G(^QA(741.6,+$P(X,"^",5),0)) Q:(FIND'>0)!(FIND=11)
. S FIND(FIND)=1
. Q
S FIND=$S(FIND(12)&FIND(13):"2&3",FIND(12):"2",FIND(13):"3",1:"")
Q:FIND="" S FIND="LEVEL "_FIND
S PAT=$S($D(^DPT(+QAOSZERO,0))#2:^(0),1:+QAOSZERO),SSN=$P(PAT,"^",9),PAT=$P(PAT,"^"),SCRN=$S($D(^QA(741.1,SCRN,0))#2:+^(0),1:SCRN),DATE=$P(QAOSZERO,"^",3)
S SERV=$P(QAOSZERO,"^",6),SERV=$S(SERV'>0:"~UNKNOWN",$D(^DIC(49,SERV,0))#2:$P(^(0),"^"),1:"~UNKNOWN"),STATUS=$S(+STATUS=0:"OPEN",1:"CLOSED")
S (ATTEND,PROV,TEAM)="" G:QAOSCHOS="X" SETUTIL
S ATTEND=$P(QAOSZERO,"^",9),PROV=$P(QAOSZERO,"^",10),TEAM=$P(QAOSZERO,"^",8) G:QAOSCHOS="C" SETUTIL
S ATTEND=$S(ATTEND'>0:"",$D(^VA(200,ATTEND,0))#2:$P(^(0),"^"),1:ATTEND),PROV=$S(PROV'>0:"",$D(^VA(200,PROV,0))#2:$P(^(0),"^"),1:PROV),TEAM=$S(TEAM'>0:"",$D(^QA(741.93,TEAM,0))#2:$P(^(0),"^"),1:TEAM)
SETUTIL S ^TMP($J,"A",SERV,PAT,SCRN,DATE)=SSN_"^"_FIND_"^"_STATUS_"^"_ATTEND_"^"_PROV_"^"_TEAM_"^"_QAOSD0
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAOSPAD0 2695 printed Sep 15, 2024@21:45:36 Page 2
QAOSPAD0 ;HISC/DAD-ADVERSE FINDINGS REPORT ;6/11/93 15:54
+1 ;;3.0;Occurrence Screen;;09/14/1993
+2 WRITE !!,"Do you want the report to include the (N)ames/(C)odes of the ATTENDING PHYSICIAN",!,"RESIDENT/PROVIDER, MEDICAL TEAM, and ATTRIBUTIONs, or none (X) of the above?",!
ASK READ !,"CHOOSE (N/C/X): N// ",X:DTIME
if '$TEST
SET X="^"
if X=""
SET X="N"
SET X=$EXTRACT(X)
if X="^"
GOTO EXIT
if X?1L
SET X=$CHAR($ASCII(X)-32)
SET QAOSCHOS=X
+1 IF (X'="N")&(X'="C")&(X'="X")
if X'="?"
WRITE " ??",*7
WRITE !!?3,"Enter 'N' to get Names",!?3," 'C' to get Codes",!?3," 'X' to print neither names or codes",!
GOTO ASK
+2 DO ^QAQDATE
if QAQQUIT
GOTO EXIT
+3 KILL %ZIS
SET %ZIS="QM"
DO ^%ZIS
if POP
GOTO EXIT
IF $DATA(IO("Q"))
SET ZTDESC="Adverse findings report"
SET ZTRTN="ENTSK^QAOSPAD0"
SET ZTSAVE("QAOS*")=""
SET ZTSAVE("QAQ*")=""
DO ^%ZTLOAD
GOTO EXIT
ENTSK ;
+1 KILL ^TMP($JOB,"A")
SET QAOSCLIN=+$ORDER(^QA(741.2,"C",1,0))
SET QAOSPEER=+$ORDER(^QA(741.2,"C",2,0))
SET QAOSEXCP=+$ORDER(^QA(741.6,"B",3,0))
+2 FOR QAOSDT=QAQNBEG-.0000001:0
SET QAOSDT=$ORDER(^QA(741,"C",QAOSDT))
if (QAOSDT'>0)!(QAOSDT>QAQNEND)
QUIT
FOR QAOSD0=0:0
SET QAOSD0=$ORDER(^QA(741,"C",QAOSDT,QAOSD0))
if QAOSD0'>0
QUIT
DO LOOP1
+3 USE IO
DO ^QAOSPAD1
EXIT ;
+1 WRITE !
DO ^%ZISC
+2 KILL %ZIS,ATTEND,DATE,DI,DH,DM,FIND,LOC,PAGE,PAT,POP,PROV,PT,QAOSCHOS,QAOSD0,QAOSDT,QAOSQUIT,QAOSZERO,SCRN,SERV,SRV,SSN,STATUS,TEAM,TODAY,UNDL,X,Y,ZTDESC,ZTRTN,ZTSAVE,%DT,D,I,Y,Z,QAOSCLIN,QAOSEXCP,QAOSD1,QAOSPEER
+3 DO K^QAQDATE
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+4 QUIT
LOOP1 ;
+1 SET QAOSZERO=^QA(741,QAOSD0,0)
SET SCRN=+$GET(^("SCRN"))
SET STATUS=+$PIECE(QAOSZERO,"^",11)
if (STATUS=2)!(SCRN'>0)
QUIT
+2 SET Y=+$ORDER(^QA(741,QAOSD0,"REVR","B",QAOSCLIN,0))
if QAOSEXCP=+$PIECE($GET(^QA(741,QAOSD0,"REVR",Y,0)),"^",5)
QUIT
+3 KILL FIND
SET (FIND(12),FIND(13))=0
+4 FOR QAOSD1=0:0
SET QAOSD1=$ORDER(^QA(741,QAOSD0,"REVR","B",QAOSPEER,QAOSD1))
if QAOSD1'>0
QUIT
Begin DoDot:1
+5 SET X=$GET(^QA(741,QAOSD0,"REVR",QAOSD1,0))
if $PIECE(X,"^",9)'>0
QUIT
+6 SET FIND=+$GET(^QA(741.6,+$PIECE(X,"^",5),0))
if (FIND'>0)!(FIND=11)
QUIT
+7 SET FIND(FIND)=1
+8 QUIT
End DoDot:1
+9 SET FIND=$SELECT(FIND(12)&FIND(13):"2&3",FIND(12):"2",FIND(13):"3",1:"")
+10 if FIND=""
QUIT
SET FIND="LEVEL "_FIND
+11 SET PAT=$SELECT($DATA(^DPT(+QAOSZERO,0))#2:^(0),1:+QAOSZERO)
SET SSN=$PIECE(PAT,"^",9)
SET PAT=$PIECE(PAT,"^")
SET SCRN=$SELECT($DATA(^QA(741.1,SCRN,0))#2:+^(0),1:SCRN)
SET DATE=$PIECE(QAOSZERO,"^",3)
+12 SET SERV=$PIECE(QAOSZERO,"^",6)
SET SERV=$SELECT(SERV'>0:"~UNKNOWN",$DATA(^DIC(49,SERV,0))#2:$PIECE(^(0),"^"),1:"~UNKNOWN")
SET STATUS=$SELECT(+STATUS=0:"OPEN",1:"CLOSED")
+13 SET (ATTEND,PROV,TEAM)=""
if QAOSCHOS="X"
GOTO SETUTIL
+14 SET ATTEND=$PIECE(QAOSZERO,"^",9)
SET PROV=$PIECE(QAOSZERO,"^",10)
SET TEAM=$PIECE(QAOSZERO,"^",8)
if QAOSCHOS="C"
GOTO SETUTIL
+15 SET ATTEND=$SELECT(ATTEND'>0:"",$DATA(^VA(200,ATTEND,0))#2:$PIECE(^(0),"^"),1:ATTEND)
SET PROV=$SELECT(PROV'>0:"",$DATA(^VA(200,PROV,0))#2:$PIECE(^(0),"^"),1:PROV)
SET TEAM=$SELECT(TEAM'>0:"",$DATA(^QA(741.93,TEAM,0))#2:$PIECE(^(0),"^"),1:TEAM)
SETUTIL SET ^TMP($JOB,"A",SERV,PAT,SCRN,DATE)=SSN_"^"_FIND_"^"_STATUS_"^"_ATTEND_"^"_PROV_"^"_TEAM_"^"_QAOSD0
+1 QUIT
