QAOSPHDR ;HISC/DAD-GENERAL WORKSHEET HEADER ;2/4/93 09:42
;;3.0;Occurrence Screen;;09/14/1993
; QAOSD0 = IEN OF RECORD IN FILE# 741
; QAOSREVR = REVIEW LEVEL # ^ SPECIFIC REVIEWER ^ REVIEW DATE
; (NOTE: ALL PIECES SHOULD BE IN EXTERNAL FORMAT)
S LOC=+$O(^QA(741.2,"C",+QAOSREVR,0)),LOC=$P($G(^QA(741.2,+LOC,0)),"^")
S:$D(QAOSPAGE)[0 QAOSPAGE=1 S HEADER=LOC_" REVIEW WORKSHEET"
I +QAOSREVR=1,QAOSHOW'=3,$D(^QA(740,1,"OS"))#2,$P(^("OS"),"^",3) S HEADER=HEADER_" (PART 2)"
S Y=DT X ^DD("DD")
W:(QAOSPAGE>1)!($E(IOST)="C") @IOF
W !!?80-$L(HEADER)/2,HEADER
I QAOSHOW'=3 W ?68,Y,!?68,"PAGE: ",QAOSPAGE
E W ?68,"PAGE: ",QAOSPAGE
D EN6^QAQAUTL
S LOCQA=$G(^QA(741,QAOSD0,0)),QAOSDFN=+LOCQA,SCRN=+$G(^("SCRN"))
S (Y,QAOSWHEN)=$P(LOCQA,"^",3) X ^DD("DD")
S LOCDPT=$G(^DPT(+LOCQA,0)),NAME=$P(LOCDPT,"^"),SSN=$P(LOCDPT,"^",9)
S SCRN=$G(^QA(741.1,SCRN,0)),SCREEN=$P(SCRN,"^",2),SCRN=+SCRN
K UNSC S $P(UNSC,"_",31)=""
W !,"PATIENT: ",$S(NAME="":UNSC,1:NAME)
W ?41,"SSN: ",$S(SSN="":$E(UNSC,1,10),1:SSN)
W ?57,"DATE: ",$S(Y="":$E(UNSC,1,17),1:Y)
I SCRN W !,SCRN,?10,SCREEN
E W !!,"SCREEN: ",UNSC,UNSC,$E(UNSC,1,10)
G:QAOSPAGE>1 UNDL
S X=+QAOSREVR,REVR=$S(X=1:"CLIN REV",X=2:"PEER REV",X=3:"MGMT REV",X=4:"CMTE REV",X=5:"VAL/CONF",1:"REVIEWER")
S LOC=$P(QAOSREVR,"^",2) W !!,REVR,": ",$S(LOC="":UNSC,1:LOC)
W ?41,"REVW DT: ",$S($P(QAOSREVR,"^",3)]"":$P(QAOSREVR,"^",3),1:UNSC)
S IEN405=+$P(LOCQA,"^",2),LOC405=$G(^DGPM(IEN405,0))
S LOC=$P(LOCQA,"^",5)
W !!,"WARD: ",$S(LOC="":UNSC,$D(^SC(LOC,0))#2:$P(^(0),"^"),1:LOC)
S LOC=$P(LOCQA,"^",6)
W ?41,"SERVICE: ",$S(LOC="":UNSC,$D(^DIC(49,LOC,0))#2:$P(^(0),"^"),1:LOC)
S LOC=$P(LOCQA,"^",7)
W !!,"TR SPEC: ",$S(LOC="":UNSC,$D(^DIC(45.7,LOC,0))#2:$P(^(0),"^"),1:LOC)
S LOC=$P(LOCQA,"^",8)
W ?41,"MED TM: ",$S(LOC="":UNSC,$D(^QA(741.93,LOC,0))#2:$P(^(0),"^"),1:LOC)
S LOC=$P(LOCQA,"^",9)
W !!,"ATTEND: ",$S(LOC="":UNSC,$D(^VA(200,LOC,0))#2:$P(^(0),"^"),1:LOC)
S LOC=$P(LOCQA,"^",10)
W ?41,"RES/PRV: ",$S(LOC="":UNSC,$D(^VA(200,LOC,0))#2:$P(^(0),"^"),1:LOC)
S Y=$P(LOC405,"^") X ^DD("DD") W !!,"ADM DATE: ",$S(Y="":UNSC,1:Y)
S LOC=$P(LOC405,"^",10) W ?41,"ADM DXS: ",$S(LOC="":UNSC,1:LOC)
S LOC=$P($G(^DIC(42,+$P(LOC405,"^",6),0)),"^")
W !!,"ADM WARD: ",$S(LOC="":UNSC,1:LOC)
S LOC=$S($G(^DPT(+LOCQA,.1))]"":^(.1),1:UNSC)
W ?41,"CUR WRD: ",$S(LOC="":UNSC,1:LOC)
D 101:SCRN\1=101,106:SCRN\1=106,109:SCRN=109
UNDL K UNDL S $P(UNDL,"=",80)="=",QAOSPAGE=QAOSPAGE+1 W !,UNDL
Q
101 ;
S QA=+$P($G(^QA(741,QAOSD0,0)),"^",2),QA=$P($G(^DGPM(QA,0)),"^")
S QA=+$O(^DGPM("ATID3",QAOSDFN,9999999.9999999-QA))
S QA=+$O(^DGPM("ATID3",QAOSDFN,QA,0)),(Y,SRV)=""
I QA D
. K VAIP S DFN=QAOSDFN,VAIP("E")=QA D IN5^VADPT
. S Y=$P(VAIP(3),"^",2),SRV=+VAIP(8),SRV=+$P($G(^DIC(45.7,SRV,0)),"^",4)
. S SRV=$P($G(^DIC(49,SRV,0)),"^") K VAIP
W !!,"D/C DATE: ",$S(Y="":UNSC,1:Y)
W ?41,"D/C SRV: ",$S(SRV="":UNSC,1:SRV)
Q
106 ;
S SRV=+$P($G(^QA(741,QAOSD0,0)),"^",6),SRV=$P($G(^DIC(49,SRV,0)),"^")
W !!,"ORG SRV: ",$S(SRV="":UNSC,1:SRV)
Q
109 ;
W !!,"AUTOPSY REQUESTED ( Y / N )",?41,"PERFORMED ( Y / N ) CIRCLE 'Y' OR 'N'"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAOSPHDR 3168 printed Dec 13, 2024@02:21:43 Page 2
QAOSPHDR ;HISC/DAD-GENERAL WORKSHEET HEADER ;2/4/93 09:42
+1 ;;3.0;Occurrence Screen;;09/14/1993
+2 ; QAOSD0 = IEN OF RECORD IN FILE# 741
+3 ; QAOSREVR = REVIEW LEVEL # ^ SPECIFIC REVIEWER ^ REVIEW DATE
+4 ; (NOTE: ALL PIECES SHOULD BE IN EXTERNAL FORMAT)
+5 SET LOC=+$ORDER(^QA(741.2,"C",+QAOSREVR,0))
SET LOC=$PIECE($GET(^QA(741.2,+LOC,0)),"^")
+6 if $DATA(QAOSPAGE)[0
SET QAOSPAGE=1
SET HEADER=LOC_" REVIEW WORKSHEET"
+7 IF +QAOSREVR=1
IF QAOSHOW'=3
IF $DATA(^QA(740,1,"OS"))#2
IF $PIECE(^("OS"),"^",3)
SET HEADER=HEADER_" (PART 2)"
+8 SET Y=DT
XECUTE ^DD("DD")
+9 if (QAOSPAGE>1)!($EXTRACT(IOST)="C")
WRITE @IOF
+10 WRITE !!?80-$LENGTH(HEADER)/2,HEADER
+11 IF QAOSHOW'=3
WRITE ?68,Y,!?68,"PAGE: ",QAOSPAGE
+12 IF '$TEST
WRITE ?68,"PAGE: ",QAOSPAGE
+13 DO EN6^QAQAUTL
+14 SET LOCQA=$GET(^QA(741,QAOSD0,0))
SET QAOSDFN=+LOCQA
SET SCRN=+$GET(^("SCRN"))
+15 SET (Y,QAOSWHEN)=$PIECE(LOCQA,"^",3)
XECUTE ^DD("DD")
+16 SET LOCDPT=$GET(^DPT(+LOCQA,0))
SET NAME=$PIECE(LOCDPT,"^")
SET SSN=$PIECE(LOCDPT,"^",9)
+17 SET SCRN=$GET(^QA(741.1,SCRN,0))
SET SCREEN=$PIECE(SCRN,"^",2)
SET SCRN=+SCRN
+18 KILL UNSC
SET $PIECE(UNSC,"_",31)=""
+19 WRITE !,"PATIENT: ",$SELECT(NAME="":UNSC,1:NAME)
+20 WRITE ?41,"SSN: ",$SELECT(SSN="":$EXTRACT(UNSC,1,10),1:SSN)
+21 WRITE ?57,"DATE: ",$SELECT(Y="":$EXTRACT(UNSC,1,17),1:Y)
+22 IF SCRN
WRITE !,SCRN,?10,SCREEN
+23 IF '$TEST
WRITE !!,"SCREEN: ",UNSC,UNSC,$EXTRACT(UNSC,1,10)
+24 if QAOSPAGE>1
GOTO UNDL
+25 SET X=+QAOSREVR
SET REVR=$SELECT(X=1:"CLIN REV",X=2:"PEER REV",X=3:"MGMT REV",X=4:"CMTE REV",X=5:"VAL/CONF",1:"REVIEWER")
+26 SET LOC=$PIECE(QAOSREVR,"^",2)
WRITE !!,REVR,": ",$SELECT(LOC="":UNSC,1:LOC)
+27 WRITE ?41,"REVW DT: ",$SELECT($PIECE(QAOSREVR,"^",3)]"":$PIECE(QAOSREVR,"^",3),1:UNSC)
+28 SET IEN405=+$PIECE(LOCQA,"^",2)
SET LOC405=$GET(^DGPM(IEN405,0))
+29 SET LOC=$PIECE(LOCQA,"^",5)
+30 WRITE !!,"WARD: ",$SELECT(LOC="":UNSC,$DATA(^SC(LOC,0))#2:$PIECE(^(0),"^"),1:LOC)
+31 SET LOC=$PIECE(LOCQA,"^",6)
+32 WRITE ?41,"SERVICE: ",$SELECT(LOC="":UNSC,$DATA(^DIC(49,LOC,0))#2:$PIECE(^(0),"^"),1:LOC)
+33 SET LOC=$PIECE(LOCQA,"^",7)
+34 WRITE !!,"TR SPEC: ",$SELECT(LOC="":UNSC,$DATA(^DIC(45.7,LOC,0))#2:$PIECE(^(0),"^"),1:LOC)
+35 SET LOC=$PIECE(LOCQA,"^",8)
+36 WRITE ?41,"MED TM: ",$SELECT(LOC="":UNSC,$DATA(^QA(741.93,LOC,0))#2:$PIECE(^(0),"^"),1:LOC)
+37 SET LOC=$PIECE(LOCQA,"^",9)
+38 WRITE !!,"ATTEND: ",$SELECT(LOC="":UNSC,$DATA(^VA(200,LOC,0))#2:$PIECE(^(0),"^"),1:LOC)
+39 SET LOC=$PIECE(LOCQA,"^",10)
+40 WRITE ?41,"RES/PRV: ",$SELECT(LOC="":UNSC,$DATA(^VA(200,LOC,0))#2:$PIECE(^(0),"^"),1:LOC)
+41 SET Y=$PIECE(LOC405,"^")
XECUTE ^DD("DD")
WRITE !!,"ADM DATE: ",$SELECT(Y="":UNSC,1:Y)
+42 SET LOC=$PIECE(LOC405,"^",10)
WRITE ?41,"ADM DXS: ",$SELECT(LOC="":UNSC,1:LOC)
+43 SET LOC=$PIECE($GET(^DIC(42,+$PIECE(LOC405,"^",6),0)),"^")
+44 WRITE !!,"ADM WARD: ",$SELECT(LOC="":UNSC,1:LOC)
+45 SET LOC=$SELECT($GET(^DPT(+LOCQA,.1))]"":^(.1),1:UNSC)
+46 WRITE ?41,"CUR WRD: ",$SELECT(LOC="":UNSC,1:LOC)
+47 if SCRN\1=101
DO 101
if SCRN\1=106
DO 106
if SCRN=109
DO 109
UNDL KILL UNDL
SET $PIECE(UNDL,"=",80)="="
SET QAOSPAGE=QAOSPAGE+1
WRITE !,UNDL
+1 QUIT
101 ;
+1 SET QA=+$PIECE($GET(^QA(741,QAOSD0,0)),"^",2)
SET QA=$PIECE($GET(^DGPM(QA,0)),"^")
+2 SET QA=+$ORDER(^DGPM("ATID3",QAOSDFN,9999999.9999999-QA))
+3 SET QA=+$ORDER(^DGPM("ATID3",QAOSDFN,QA,0))
SET (Y,SRV)=""
+4 IF QA
Begin DoDot:1
+5 KILL VAIP
SET DFN=QAOSDFN
SET VAIP("E")=QA
DO IN5^VADPT
+6 SET Y=$PIECE(VAIP(3),"^",2)
SET SRV=+VAIP(8)
SET SRV=+$PIECE($GET(^DIC(45.7,SRV,0)),"^",4)
+7 SET SRV=$PIECE($GET(^DIC(49,SRV,0)),"^")
KILL VAIP
End DoDot:1
+8 WRITE !!,"D/C DATE: ",$SELECT(Y="":UNSC,1:Y)
+9 WRITE ?41,"D/C SRV: ",$SELECT(SRV="":UNSC,1:SRV)
+10 QUIT
106 ;
+1 SET SRV=+$PIECE($GET(^QA(741,QAOSD0,0)),"^",6)
SET SRV=$PIECE($GET(^DIC(49,SRV,0)),"^")
+2 WRITE !!,"ORG SRV: ",$SELECT(SRV="":UNSC,1:SRV)
+3 QUIT
109 ;
+1 WRITE !!,"AUTOPSY REQUESTED ( Y / N )",?41,"PERFORMED ( Y / N ) CIRCLE 'Y' OR 'N'"
+2 QUIT