| 1 | QAOSPAD0 ;HISC/DAD-ADVERSE FINDINGS REPORT ;6/11/93 15:54
|
|---|
| 2 | ;;3.0;Occurrence Screen;;09/14/1993
|
|---|
| 3 | 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?",!
|
|---|
| 4 | 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
|
|---|
| 5 | 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
|
|---|
| 6 | D ^QAQDATE G:QAQQUIT EXIT
|
|---|
| 7 | 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
|
|---|
| 8 | ENTSK ;
|
|---|
| 9 | 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))
|
|---|
| 10 | 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
|
|---|
| 11 | U IO D ^QAOSPAD1
|
|---|
| 12 | EXIT ;
|
|---|
| 13 | W ! D ^%ZISC
|
|---|
| 14 | 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
|
|---|
| 15 | D K^QAQDATE S:$D(ZTQUEUED) ZTREQ="@"
|
|---|
| 16 | Q
|
|---|
| 17 | LOOP1 ;
|
|---|
| 18 | S QAOSZERO=^QA(741,QAOSD0,0),SCRN=+$G(^("SCRN")),STATUS=+$P(QAOSZERO,"^",11) Q:(STATUS=2)!(SCRN'>0)
|
|---|
| 19 | S Y=+$O(^QA(741,QAOSD0,"REVR","B",QAOSCLIN,0)) Q:QAOSEXCP=+$P($G(^QA(741,QAOSD0,"REVR",Y,0)),"^",5)
|
|---|
| 20 | K FIND S (FIND(12),FIND(13))=0
|
|---|
| 21 | F QAOSD1=0:0 S QAOSD1=$O(^QA(741,QAOSD0,"REVR","B",QAOSPEER,QAOSD1)) Q:QAOSD1'>0 D
|
|---|
| 22 | . S X=$G(^QA(741,QAOSD0,"REVR",QAOSD1,0)) Q:$P(X,"^",9)'>0
|
|---|
| 23 | . S FIND=+$G(^QA(741.6,+$P(X,"^",5),0)) Q:(FIND'>0)!(FIND=11)
|
|---|
| 24 | . S FIND(FIND)=1
|
|---|
| 25 | . Q
|
|---|
| 26 | S FIND=$S(FIND(12)&FIND(13):"2&3",FIND(12):"2",FIND(13):"3",1:"")
|
|---|
| 27 | Q:FIND="" S FIND="LEVEL "_FIND
|
|---|
| 28 | 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)
|
|---|
| 29 | 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")
|
|---|
| 30 | S (ATTEND,PROV,TEAM)="" G:QAOSCHOS="X" SETUTIL
|
|---|
| 31 | S ATTEND=$P(QAOSZERO,"^",9),PROV=$P(QAOSZERO,"^",10),TEAM=$P(QAOSZERO,"^",8) G:QAOSCHOS="C" SETUTIL
|
|---|
| 32 | 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)
|
|---|
| 33 | SETUTIL S ^TMP($J,"A",SERV,PAT,SCRN,DATE)=SSN_"^"_FIND_"^"_STATUS_"^"_ATTEND_"^"_PROV_"^"_TEAM_"^"_QAOSD0
|
|---|
| 34 | Q
|
|---|
