QAOSPAD1 ;HISC/DAD-ADVERSE FINDINGS REPORT ;2/12/93 15:13
;;3.0;Occurrence Screen;;09/14/1993
S QAOSQUIT=0,PAGE=1,Y=DT X ^DD("DD") S TODAY=$P(Y,"@") K UNDL S $P(UNDL,"-",80)="-"
D HEAD I '$D(^TMP($J,"A")) W !!,"NO DATA FOUND FOR THIS REPORT" G EXIT
S SERV="" F SRV=0:0 S SERV=$O(^TMP($J,"A",SERV)) Q:SERV=""!QAOSQUIT D SUBHEAD S PAT="" F PT=0:0 S PAT=$O(^TMP($J,"A",SERV,PAT)) Q:PAT=""!QAOSQUIT F SCRN=0:0 S SCRN=$O(^TMP($J,"A",SERV,PAT,SCRN)) Q:SCRN'>0!QAOSQUIT D LOOP1
EXIT ;
Q
LOOP1 ;
F DATE=0:0 S DATE=$O(^TMP($J,"A",SERV,PAT,SCRN,DATE)) Q:DATE'>0!QAOSQUIT D LOOP2
Q
LOOP2 ;
S LOC=^TMP($J,"A",SERV,PAT,SCRN,DATE),SSN=$P(LOC,"^"),FIND=$P(LOC,"^",2),STATUS=$P(LOC,"^",3),ATTEND=$P(LOC,"^",4),PROV=$P(LOC,"^",5),TEAM=$P(LOC,"^",6),QAOSD0=$P(LOC,"^",7),Y=DATE\1 X ^DD("DD")
W:QAOSCHOS'="X" ! W !!,PAT,?32,SSN,?43,Y,?56,SCRN,?63,STATUS,?71,FIND
W !,$E(ATTEND,1,25),?27,$E(TEAM,1,25),?54,$E(PROV,1,25)
I $Y>(IOSL-6) D:$E(IOST)="C" PAUSE Q:QAOSQUIT D HEAD
Q:QAOSCHOS="X" S (DI,DM,DH)=.001
I $O(^QA(741,QAOSD0,"ATRI",0))!$O(^QA(741,QAOSD0,"ATRT",0))!$O(^QA(741,QAOSD0,"ATRL",0)) W !,"-ATTRIBUTION(INDIVIDUAL)-",?27,"-ATTRIBUTION(MEDICAL TEAM)-",?56,"-ATTRIBUTION(HOSP LOC)-"
E Q
LOOP3 ;
W ! D INDIV:DI,TEAM:DM,HOSPL:DH
I $Y>(IOSL-6) D:$E(IOST)="C" PAUSE Q:QAOSQUIT D HEAD W:$O(^QA(741,QAOSD0,"ATRI",DI))!$O(^QA(741,QAOSD0,"ATRT",DM))!$O(^QA(741,QAOSD0,"ATRL",DH)) !,"-ATTRIBUTION(INDIVIDUAL)-",?27,"-ATTRIBUTION(MEDICAL TEAM)-",?56,"-ATTRIBUTION(HOSP LOC)-"
G:DI!DM!DH LOOP3
Q
INDIV ;
S DI=$O(^QA(741,QAOSD0,"ATRI",DI)) Q:DI'>0 S X=$S($D(^QA(741,QAOSD0,"ATRI",DI,0))#2:+^(0),1:""),X=$S(X'>0:X,($D(^VA(200,X,0))#2)&(QAOSCHOS="N"):$P(^(0),"^"),1:X) W $E(X,1,25)
Q
TEAM ;
S DM=$O(^QA(741,QAOSD0,"ATRT",DM)) Q:DM'>0 S X=$S($D(^QA(741,QAOSD0,"ATRT",DM,0))#2:+^(0),1:""),X=$S(X'>0:X,($D(^QA(741.93,X,0))#2)&(QAOSCHOS="N"):$P(^(0),"^"),1:X) W ?27,$E(X,1,25)
Q
HOSPL ;
S DH=$O(^QA(741,QAOSD0,"ATRL",DH)) Q:DH'>0 S X=$S($D(^QA(741,QAOSD0,"ATRL",DH,0))#2:+^(0),1:""),X=$S(X'>0:X,($D(^SC(X,0))#2)&(QAOSCHOS="N"):$P(^(0),"^"),1:X) W ?56,$E(X,1,25)
Q
HEAD ;
W:(PAGE>1)!($E(IOST)="C") @IOF
W !!?32,"ADVERSE FINDINGS",?68,TODAY,!?QAQTART,QAQ2HED,?68,"PAGE: ",PAGE S PAGE=PAGE+1
D EN6^QAQAUTL
W !,"PATIENT",?32,"SSN",?43,"OCCURRENCE",?56,"SCREEN",?63,"STATUS",?71,"LEVEL" W:QAOSCHOS'="X" !,"ATTENDING PHYSICIAN",?27,"MEDICAL TEAM",?54,"RESIDENT/PROVIDER" W !,UNDL
Q
SUBHEAD ;
W !!?3,"SERVICE: ",$S(SERV["~":$P(SERV,"~",2),1:SERV)
Q
PAUSE ;
K DIR S DIR(0)="E" D ^DIR K DIR S QAOSQUIT=$S(Y'>0:1,1:0)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAOSPAD1 2569 printed Nov 22, 2024@17:31:35 Page 2
QAOSPAD1 ;HISC/DAD-ADVERSE FINDINGS REPORT ;2/12/93 15:13
+1 ;;3.0;Occurrence Screen;;09/14/1993
+2 SET QAOSQUIT=0
SET PAGE=1
SET Y=DT
XECUTE ^DD("DD")
SET TODAY=$PIECE(Y,"@")
KILL UNDL
SET $PIECE(UNDL,"-",80)="-"
+3 DO HEAD
IF '$DATA(^TMP($JOB,"A"))
WRITE !!,"NO DATA FOUND FOR THIS REPORT"
GOTO EXIT
+4 SET SERV=""
FOR SRV=0:0
SET SERV=$ORDER(^TMP($JOB,"A",SERV))
if SERV=""!QAOSQUIT
QUIT
DO SUBHEAD
SET PAT=""
FOR PT=0:0
SET PAT=$ORDER(^TMP($JOB,"A",SERV,PAT))
if PAT=""!QAOSQUIT
QUIT
FOR SCRN=0:0
SET SCRN=$ORDER(^TMP($JOB,"A",SERV,PAT,SCRN))
if SCRN'>0!QAOSQUIT
QUIT
DO LOOP1
EXIT ;
+1 QUIT
LOOP1 ;
+1 FOR DATE=0:0
SET DATE=$ORDER(^TMP($JOB,"A",SERV,PAT,SCRN,DATE))
if DATE'>0!QAOSQUIT
QUIT
DO LOOP2
+2 QUIT
LOOP2 ;
+1 SET LOC=^TMP($JOB,"A",SERV,PAT,SCRN,DATE)
SET SSN=$PIECE(LOC,"^")
SET FIND=$PIECE(LOC,"^",2)
SET STATUS=$PIECE(LOC,"^",3)
SET ATTEND=$PIECE(LOC,"^",4)
SET PROV=$PIECE(LOC,"^",5)
SET TEAM=$PIECE(LOC,"^",6)
SET QAOSD0=$PIECE(LOC,"^",7)
SET Y=DATE\1
XECUTE ^DD("DD")
+2 if QAOSCHOS'="X"
WRITE !
WRITE !!,PAT,?32,SSN,?43,Y,?56,SCRN,?63,STATUS,?71,FIND
+3 WRITE !,$EXTRACT(ATTEND,1,25),?27,$EXTRACT(TEAM,1,25),?54,$EXTRACT(PROV,1,25)
+4 IF $Y>(IOSL-6)
if $EXTRACT(IOST)="C"
DO PAUSE
if QAOSQUIT
QUIT
DO HEAD
+5 if QAOSCHOS="X"
QUIT
SET (DI,DM,DH)=.001
+6 IF $ORDER(^QA(741,QAOSD0,"ATRI",0))!$ORDER(^QA(741,QAOSD0,"ATRT",0))!$ORDER(^QA(741,QAOSD0,"ATRL",0))
WRITE !,"-ATTRIBUTION(INDIVIDUAL)-",?27,"-ATTRIBUTION(MEDICAL TEAM)-",?56,"-ATTRIBUTION(HOSP LOC)-"
+7 IF '$TEST
QUIT
LOOP3 ;
+1 WRITE !
if DI
DO INDIV
if DM
DO TEAM
if DH
DO HOSPL
+2 IF $Y>(IOSL-6)
if $EXTRACT(IOST)="C"
DO PAUSE
if QAOSQUIT
QUIT
DO HEAD
if $ORDER(^QA(741,QAOSD0,"ATRI",DI))!$ORDER(^QA(741,QAOSD0,"ATRT",DM))!$ORDER(^QA(741,QAOSD0,"ATRL",DH))
WRITE !,"-ATTRIBUTION(INDIVIDUAL)-",?27,"-ATTRIBUTION(MEDICAL TEAM)-",?56,"-ATTRIBUTION(HOSP LOC)-"
+3 if DI!DM!DH
GOTO LOOP3
+4 QUIT
INDIV ;
+1 SET DI=$ORDER(^QA(741,QAOSD0,"ATRI",DI))
if DI'>0
QUIT
SET X=$SELECT($DATA(^QA(741,QAOSD0,"ATRI",DI,0))#2:+^(0),1:"")
SET X=$SELECT(X'>0:X,($DATA(^VA(200,X,0))#2)&(QAOSCHOS="N"):$PIECE(^(0),"^"),1:X)
WRITE $EXTRACT(X,1,25)
+2 QUIT
TEAM ;
+1 SET DM=$ORDER(^QA(741,QAOSD0,"ATRT",DM))
if DM'>0
QUIT
SET X=$SELECT($DATA(^QA(741,QAOSD0,"ATRT",DM,0))#2:+^(0),1:"")
SET X=$SELECT(X'>0:X,($DATA(^QA(741.93,X,0))#2)&(QAOSCHOS="N"):$PIECE(^(0),"^"),1:X)
WRITE ?27,$EXTRACT(X,1,25)
+2 QUIT
HOSPL ;
+1 SET DH=$ORDER(^QA(741,QAOSD0,"ATRL",DH))
if DH'>0
QUIT
SET X=$SELECT($DATA(^QA(741,QAOSD0,"ATRL",DH,0))#2:+^(0),1:"")
SET X=$SELECT(X'>0:X,($DATA(^SC(X,0))#2)&(QAOSCHOS="N"):$PIECE(^(0),"^"),1:X)
WRITE ?56,$EXTRACT(X,1,25)
+2 QUIT
HEAD ;
+1 if (PAGE>1)!($EXTRACT(IOST)="C")
WRITE @IOF
+2 WRITE !!?32,"ADVERSE FINDINGS",?68,TODAY,!?QAQTART,QAQ2HED,?68,"PAGE: ",PAGE
SET PAGE=PAGE+1
+3 DO EN6^QAQAUTL
+4 WRITE !,"PATIENT",?32,"SSN",?43,"OCCURRENCE",?56,"SCREEN",?63,"STATUS",?71,"LEVEL"
if QAOSCHOS'="X"
WRITE !,"ATTENDING PHYSICIAN",?27,"MEDICAL TEAM",?54,"RESIDENT/PROVIDER"
WRITE !,UNDL
+5 QUIT
SUBHEAD ;
+1 WRITE !!?3,"SERVICE: ",$SELECT(SERV["~":$PIECE(SERV,"~",2),1:SERV)
+2 QUIT
PAUSE ;
+1 KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
SET QAOSQUIT=$SELECT(Y'>0:1,1:0)
+2 QUIT
