ONCOCOC ;Hines OIFO/GWB - COMPUTED FIELDS FOR CASEFINDING REPORTS ;05/25/00
;;2.2;ONCOLOGY;**1,7**;Jul 31, 2013;Build 5
;
LAB ;LAB CASEFINDING REPORT (160,53)
N X
D GET G EX:O2=""
S SR=$P(O2,U,3) G EX:$E(SR,1)'="L"
S SR=$E(SR,2),LRSS=$S(SR="S":"SP",SR="C":"CY",SR="E":"EM",1:"AU")
S XDT=$P(O2,U,1),MO=$P(O2,U,5),TO=$P(O2,U,6),DZ=$P(O2,U,14)
S TO=$S(TO="":"None",1:"T-"_$P(^LAB(61,+TO,0),U,2)_" "_$P(^LAB(61,+TO,0),U,1))
S MODZ="None"
I MO S MODZ=$G(^LAB(61.1,+MO,0)),MODZ=$E($P(MODZ,U,2),1,4)_"/"_$E($P(MODZ,U,2),5)_" "_$P(MODZ,U,1)
I DZ S MODZ=$G(^LAB(61.4,+DZ,0)),MODZ=$P(MODZ,U,2)_" "_$P(MODZ,U,1)
D DT
W $E(XNM,1,20),?22,$E(XSN,1,6),?29,XDT,?44,LRSS
I $D(^ONCO(165.5,"C",D0)) D DLC^ONCOCRF,DATEOT^ONCOES W ?54,X
W !
W "Topography:",?12,TO,!
W:MO "Morphology:",?13,MODZ
W:DZ "Disease:",?15,MODZ
D SDD^ONCOCOM
W !,"-------------------------------------------------------------------------------"
W ! G EX
;
PTF ;PTF CASEFINDING REPORT (160,54)
N ONCIC
D GET G EX:O2=""
S SR=$P(O2,U,3) G EX:$E(SR,1)'="P"
S ONCIC=$$GET1^DIQ(80,+$P(O2,U,9),.01,"I")
S IC=$$ICDDX^ICDEXC(ONCIC) G EX:+IC=-1
S XDT=+$P(O2,U,8)
D DT
S XDD=XDT,XDT=$P(O2,U,1)
D DT
W $E(XNM,1,20),?22,XSN,?29,XDT_" - "_XDD,!
W "Diagnosis:",?11,$P(IC,U,2),?19,$P(IC,U,4),!!
G LST
;
RAD ;RADIOLOGY CASEFINDING REPORT (160,58)
D GET G EX:O2=""
S SR=$P(O2,U,3) G EX:$E(SR,1)'="R"
S XDT=$P(O2,U,1),RAD=$P($G(^RAMIS(71,+$P(O2,U,7),0)),U) G EX:RAD=""
D DT
;B "L"
W $E(XNM,1,29),?31,XSN,?38,XDT,?50,$E(RAD,1,30)
G LST
;
GET ;Set variables
S XD0=$G(^ONCO(160,D0,0)),GLO="" I XD0="" Q
S LRDFN=$P(XD0,U,2)
S VPR=$P(XD0,U)
S GLO=U_$P(VPR,";",2)_$P(VPR,";"),GL0=GLO_",0)"
S XPI=$G(@GL0),XNM=$P(XPI,U),SN=$P(XPI,U,9),XSN=$E(XNM,1)_$E(SN,6,9)
S O2="" I $D(^ONCO(160,D0,"SUS","C",DUZ(2))) D K SUSIEN
.S SUSIEN=$O(^ONCO(160,D0,"SUS","C",DUZ(2),0))
.S O2=^ONCO(160,D0,"SUS",SUSIEN,0)
Q
;
DT ;Format date
S XDT=$E(XDT,4,5)_"/"_$E(XDT,6,7)_"/"_($E(XDT,1,3)+1700)
Q
;
LST ;Display DATE LAST CONTACT (160,16) and primary list
G EX:'$D(^ONCO(165.5,"C",D0))
D DLC^ONCOCRF,DATEOT^ONCOES
W !!?25,"Last Contact: ",X
D SDD^ONCOCOM
W ! G EX
;
EX ;Exit
S X=""
K DZ,GL0,GLO,IC,LRDFN,LRSS,MO,MODZ,O2,RAD,SN,SR,TO,VPR,XDT,XD0,XDD,XMO
K XM1,XNM,XPI,XSN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HONCOCOC 2325 printed Dec 13, 2024@02:24:35 Page 2
ONCOCOC ;Hines OIFO/GWB - COMPUTED FIELDS FOR CASEFINDING REPORTS ;05/25/00
+1 ;;2.2;ONCOLOGY;**1,7**;Jul 31, 2013;Build 5
+2 ;
LAB ;LAB CASEFINDING REPORT (160,53)
+1 NEW X
+2 DO GET
if O2=""
GOTO EX
+3 SET SR=$PIECE(O2,U,3)
if $EXTRACT(SR,1)'="L"
GOTO EX
+4 SET SR=$EXTRACT(SR,2)
SET LRSS=$SELECT(SR="S":"SP",SR="C":"CY",SR="E":"EM",1:"AU")
+5 SET XDT=$PIECE(O2,U,1)
SET MO=$PIECE(O2,U,5)
SET TO=$PIECE(O2,U,6)
SET DZ=$PIECE(O2,U,14)
+6 SET TO=$SELECT(TO="":"None",1:"T-"_$PIECE(^LAB(61,+TO,0),U,2)_" "_$PIECE(^LAB(61,+TO,0),U,1))
+7 SET MODZ="None"
+8 IF MO
SET MODZ=$GET(^LAB(61.1,+MO,0))
SET MODZ=$EXTRACT($PIECE(MODZ,U,2),1,4)_"/"_$EXTRACT($PIECE(MODZ,U,2),5)_" "_$PIECE(MODZ,U,1)
+9 IF DZ
SET MODZ=$GET(^LAB(61.4,+DZ,0))
SET MODZ=$PIECE(MODZ,U,2)_" "_$PIECE(MODZ,U,1)
+10 DO DT
+11 WRITE $EXTRACT(XNM,1,20),?22,$EXTRACT(XSN,1,6),?29,XDT,?44,LRSS
+12 IF $DATA(^ONCO(165.5,"C",D0))
DO DLC^ONCOCRF
DO DATEOT^ONCOES
WRITE ?54,X
+13 WRITE !
+14 WRITE "Topography:",?12,TO,!
+15 if MO
WRITE "Morphology:",?13,MODZ
+16 if DZ
WRITE "Disease:",?15,MODZ
+17 DO SDD^ONCOCOM
+18 WRITE !,"-------------------------------------------------------------------------------"
+19 WRITE !
GOTO EX
+20 ;
PTF ;PTF CASEFINDING REPORT (160,54)
+1 NEW ONCIC
+2 DO GET
if O2=""
GOTO EX
+3 SET SR=$PIECE(O2,U,3)
if $EXTRACT(SR,1)'="P"
GOTO EX
+4 SET ONCIC=$$GET1^DIQ(80,+$PIECE(O2,U,9),.01,"I")
+5 SET IC=$$ICDDX^ICDEXC(ONCIC)
if +IC=-1
GOTO EX
+6 SET XDT=+$PIECE(O2,U,8)
+7 DO DT
+8 SET XDD=XDT
SET XDT=$PIECE(O2,U,1)
+9 DO DT
+10 WRITE $EXTRACT(XNM,1,20),?22,XSN,?29,XDT_" - "_XDD,!
+11 WRITE "Diagnosis:",?11,$PIECE(IC,U,2),?19,$PIECE(IC,U,4),!!
+12 GOTO LST
+13 ;
RAD ;RADIOLOGY CASEFINDING REPORT (160,58)
+1 DO GET
if O2=""
GOTO EX
+2 SET SR=$PIECE(O2,U,3)
if $EXTRACT(SR,1)'="R"
GOTO EX
+3 SET XDT=$PIECE(O2,U,1)
SET RAD=$PIECE($GET(^RAMIS(71,+$PIECE(O2,U,7),0)),U)
if RAD=""
GOTO EX
+4 DO DT
+5 ;B "L"
+6 WRITE $EXTRACT(XNM,1,29),?31,XSN,?38,XDT,?50,$EXTRACT(RAD,1,30)
+7 GOTO LST
+8 ;
GET ;Set variables
+1 SET XD0=$GET(^ONCO(160,D0,0))
SET GLO=""
IF XD0=""
QUIT
+2 SET LRDFN=$PIECE(XD0,U,2)
+3 SET VPR=$PIECE(XD0,U)
+4 SET GLO=U_$PIECE(VPR,";",2)_$PIECE(VPR,";")
SET GL0=GLO_",0)"
+5 SET XPI=$GET(@GL0)
SET XNM=$PIECE(XPI,U)
SET SN=$PIECE(XPI,U,9)
SET XSN=$EXTRACT(XNM,1)_$EXTRACT(SN,6,9)
+6 SET O2=""
IF $DATA(^ONCO(160,D0,"SUS","C",DUZ(2)))
Begin DoDot:1
+7 SET SUSIEN=$ORDER(^ONCO(160,D0,"SUS","C",DUZ(2),0))
+8 SET O2=^ONCO(160,D0,"SUS",SUSIEN,0)
End DoDot:1
KILL SUSIEN
+9 QUIT
+10 ;
DT ;Format date
+1 SET XDT=$EXTRACT(XDT,4,5)_"/"_$EXTRACT(XDT,6,7)_"/"_($EXTRACT(XDT,1,3)+1700)
+2 QUIT
+3 ;
LST ;Display DATE LAST CONTACT (160,16) and primary list
+1 if '$DATA(^ONCO(165.5,"C",D0))
GOTO EX
+2 DO DLC^ONCOCRF
DO DATEOT^ONCOES
+3 WRITE !!?25,"Last Contact: ",X
+4 DO SDD^ONCOCOM
+5 WRITE !
GOTO EX
+6 ;
EX ;Exit
+1 SET X=""
+2 KILL DZ,GL0,GLO,IC,LRDFN,LRSS,MO,MODZ,O2,RAD,SN,SR,TO,VPR,XDT,XD0,XDD,XMO
+3 KILL XM1,XNM,XPI,XSN
+4 QUIT
