ONCOCON ;Hines OIFO/GWB - VADPT calls ;06/23/10
;;2.2;ONCOLOGY;**1**;Jul 31, 2013;Build 8
;
NOK ;NEXT OF KIN
S XD0=D0 D VP G EX:OP=""
N I,X
D OAD^VADPT G EX:VAERR
S ST=$S(VAOA(5)="":"",1:$P(^DIC(5,$P(VAOA(5),U),0),U,2)),CSZ=VAOA(4)
I CSZ'="" S CSZ=CSZ_", "
S CSZ=CSZ_ST_" "_VAOA(6),SP="?25" S:'$D(NOK) NOK="NOK"
D WT
G EX
;
NOK1 ;NEXT OF KIN-1
S NOK="NOK1" G NOK
;
NOK2 ;NEXT OF KIN-2 #.2191
S VAOA("A")=3,NOK="NOK2" G NOK
;
CON ;Retrieve Contacts (NOK1 and NOK@)
S XD0=D0 D VP G EX:OP="" N I,X D OAD^VADPT F I=1:1:10 S ONCO(I)=VAOA(I)
K VAOA S VAOA("A")=3 D OAD^VADPT F I=1:1:10 S ONCO(I+10)=VAOA(I)
G EX
;
WT W !,@SP,NOK,": ",@SP,VAOA(10)
2 ;W !?25,VAOA(10)
3 W !,@SP,$P(VAOA(9),",",2)_" "_$P(VAOA(9),",")
4 W !,@SP,VAOA(1)
5 W:VAOA(2)'="" !,@SP,VAOA(2)
6 W:VAOA(3)'="" !,@SP,VAOA(3)
W:CSZ'="" !,@SP,CSZ
Q
;
REL2 ;NOK2
S VAOA("A")=3 G REL
REL ;NOK relationship and Name
S XD0=D0 D VP G EX:OP="" N I D OAD^VADPT G EX:VAERR S X=$S(VAOA(9)="":"",1:VAOA(10)_": "_$P(VAOA(9),",",2)_" "_$P(VAOA(9),",",1)_" * "_VAOA(1)) K ONCOD0 G EX:X="" I VAOA(2)'="" S X=X_" "_VAOA(2)
S:VAOA(3)'="" X=X_" "_VAOA(3) S X=X_" "_VAOA(4)_", "_$P(VAOA(5),U,2)_" "_VAOA(6) G EX
;
ADM ;Admission date/Discharge date
;FOR NON-DHCP (EAST-ORANGE)
S (ONCOAD,ONCODD)="" I $G(^DG(43,1,"VERSION"))<4.6 Q ;FOR NON-DHCP EAST-ORANGE
S XX=$S($D(^ONCO(165.5,D0,0)):^(0),1:"") Q:XX="" S XD0=$P(XX,U,2) D VP Q:OP="" S XD=$P(XX,U,16),VAIP("D")=$S(XD="":"L",1:XD)
A5 I $G(^DG(43,1,"VERSION"))>4.8 N I,X D IN5 G:VAIP(1)'="" SV G:XD="" EX G NO
A4 G:XD="" EX S VAINDT=XD N I,X D INP G:VAIN(1)="" NO G SV
;
SV S ONCOAD=AD,ONCODD=XD
WE W !!?15,"Admission: ",AD_" Discharge: "_XD,! G EX
NO D DD W !,"No admission for ",XD G EX
;
INP ;MAS VERSIONS less than 5.0
N I,X D INP^VADPT Q:VAIN(1)="" S XD=$P($P(VAIN(7),U),".") D DD S AD=XD,XD=$S($D(^DPT(DFN,"DA",VAIN(1),1)):$P(^(1),U),1:"") D DD Q
;
NOKEO ;COMPUTED EXPRESSION for NOK (160,.214)
;Displays K-NAME OF PRIMARY NOK (2,.211) and
; K-RELATIONSHIP TO PATIENT (2,.212)
N RCDT
I $D(^ONCO(160,D0,0)) S RCDT=^(0) I $P(RCDT,";",2)["DPT",$D(^DPT($P(RCDT,";",1),.21)) W $P(^(.21),U)_" ("_$P(^(.21),U,2)_")"
Q
;
SAD ;COMPUTED EXPRESSION for SUSPENSE ADMIT DATE (160,33.1)
D SUS S X=$S($D(XAD):XAD,1:"")
G EX
;
SDD ;COMPUTED EXPRESSION for SUSPENSE DISCHARGE DATE (160,33.2)
D SUS S X=$S($D(XDD):XDD,1:"")
G EX
;
SEC ;COMPUTED EXPRESSION for SUSPENSE EPISODE OF CARE (160,33.3)
D SUS S X="" G:SD="" EX I '$D(AD) S XD=SD G NO
S XD=$S($D(XD):XD,1:"") G WE
;
SUS ;SUSPENSE EPISODE OF CARE
S XD0=D0,SD=""
S SDIEN=$O(^ONCO(160,XD0,"SUS","C",DUZ(2),""))
I SDIEN'="" S SD=$P($G(^ONCO(160,XD0,"SUS",SDIEN,0)),"^",1)
Q:SD="" D VP Q:OP=""
S VAIP("D")=SD D IN5
Q
;
LEC ;COMPUTED EXPRESSION for LAST EPISODE of CARE (160,34)
D LST
I '$D(AD) W "No admission data" G EX
I $D(XD) I XD'="" W "Admission: ",AD_" Discharge: "_XD G EX
W "Admission: "_AD_" (Active)" G EX
;
LAD ;COMPUTED EXPRESSION for LAST ADMIT DATE (160,34.1)
D LST S X=$S($D(AD):AD,1:"")
G EX
;
LDD ;COMPUTED EXPRESSION for LAST DISCHARGE DATE (160,34.2)
D LST S X=$S($D(XD):XD,1:"")
G EX
;
LST ;Get ADMISSION and DISCHARGE data
S XD0=D0 D VP G:OP="" EX
S VAIP("D")="L"
D IN5
Q
;
VP ;Resolve NAME (160,.01) variable pointer
S OP=$S($D(^ONCO(160,XD0,0)):$P(^(0),U),1:"")
S DFN=$P(OP,";",1)
S OF=$P(OP,";",2)
S OP=$S(OF="LRT(67,":"",1:OP)
Q
;
IN5 ;Call IN5^VADPT (Inpatient Data [v5.0 and above])
N X
D IN5^VADPT Q:VAIP(1)=""
S XD=$P(VAIP(13,1),".") D DD S AD=XD
S XD=$P(VAIP(17,1),".") D DD S XD=XD
Q
;
DD ;Format date as mm/dd/yy
S XD=$S(XD="":XD,1:$E(XD,4,5)_"/"_$E(XD,6,7)_"/"_$E(XD,2,3))
Q
;
EX ;Exit
K AD,CSZ,DFN,NOK,OF,ONCO,ONCOAD,ONCODD,OP,RCDT,SD,SDIEN,SP,ST
K VAERR,VAIN,VAIP,VAINDT,VAOA,XAD,XD,XDD,XX,XD0
Q
;
CLEANUP ;Cleanup
K D0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HONCOCON 3922 printed Dec 13, 2024@02:24:40 Page 2
ONCOCON ;Hines OIFO/GWB - VADPT calls ;06/23/10
+1 ;;2.2;ONCOLOGY;**1**;Jul 31, 2013;Build 8
+2 ;
NOK ;NEXT OF KIN
+1 SET XD0=D0
DO VP
if OP=""
GOTO EX
+2 NEW I,X
+3 DO OAD^VADPT
if VAERR
GOTO EX
+4 SET ST=$SELECT(VAOA(5)="":"",1:$PIECE(^DIC(5,$PIECE(VAOA(5),U),0),U,2))
SET CSZ=VAOA(4)
+5 IF CSZ'=""
SET CSZ=CSZ_", "
+6 SET CSZ=CSZ_ST_" "_VAOA(6)
SET SP="?25"
if '$DATA(NOK)
SET NOK="NOK"
+7 DO WT
+8 GOTO EX
+9 ;
NOK1 ;NEXT OF KIN-1
+1 SET NOK="NOK1"
GOTO NOK
+2 ;
NOK2 ;NEXT OF KIN-2 #.2191
+1 SET VAOA("A")=3
SET NOK="NOK2"
GOTO NOK
+2 ;
CON ;Retrieve Contacts (NOK1 and NOK@)
+1 SET XD0=D0
DO VP
if OP=""
GOTO EX
NEW I,X
DO OAD^VADPT
FOR I=1:1:10
SET ONCO(I)=VAOA(I)
+2 KILL VAOA
SET VAOA("A")=3
DO OAD^VADPT
FOR I=1:1:10
SET ONCO(I+10)=VAOA(I)
+3 GOTO EX
+4 ;
WT WRITE !,@SP,NOK,": ",@SP,VAOA(10)
2 ;W !?25,VAOA(10)
3 WRITE !,@SP,$PIECE(VAOA(9),",",2)_" "_$PIECE(VAOA(9),",")
4 WRITE !,@SP,VAOA(1)
5 if VAOA(2)'=""
WRITE !,@SP,VAOA(2)
6 if VAOA(3)'=""
WRITE !,@SP,VAOA(3)
+1 if CSZ'=""
WRITE !,@SP,CSZ
+2 QUIT
+3 ;
REL2 ;NOK2
+1 SET VAOA("A")=3
GOTO REL
REL ;NOK relationship and Name
+1 SET XD0=D0
DO VP
if OP=""
GOTO EX
NEW I
DO OAD^VADPT
if VAERR
GOTO EX
SET X=$SELECT(VAOA(9)="":"",1:VAOA(10)_": "_$PIECE(VAOA(9),",",2)_" "_$PIECE(VAOA(9),",",1)_" * "_VAOA(1))
KILL ONCOD0
if X=""
GOTO EX
IF VAOA(2)'=""
SET X=X_" "_VAOA(2)
+2 if VAOA(3)'=""
SET X=X_" "_VAOA(3)
SET X=X_" "_VAOA(4)_", "_$PIECE(VAOA(5),U,2)_" "_VAOA(6)
GOTO EX
+3 ;
ADM ;Admission date/Discharge date
+1 ;FOR NON-DHCP (EAST-ORANGE)
+2 ;FOR NON-DHCP EAST-ORANGE
SET (ONCOAD,ONCODD)=""
IF $GET(^DG(43,1,"VERSION"))<4.6
QUIT
+3 SET XX=$SELECT($DATA(^ONCO(165.5,D0,0)):^(0),1:"")
if XX=""
QUIT
SET XD0=$PIECE(XX,U,2)
DO VP
if OP=""
QUIT
SET XD=$PIECE(XX,U,16)
SET VAIP("D")=$SELECT(XD="":"L",1:XD)
A5 IF $GET(^DG(43,1,"VERSION"))>4.8
NEW I,X
DO IN5
if VAIP(1)'=""
GOTO SV
if XD=""
GOTO EX
GOTO NO
A4 if XD=""
GOTO EX
SET VAINDT=XD
NEW I,X
DO INP
if VAIN(1)=""
GOTO NO
GOTO SV
+1 ;
SV SET ONCOAD=AD
SET ONCODD=XD
WE WRITE !!?15,"Admission: ",AD_" Discharge: "_XD,!
GOTO EX
NO DO DD
WRITE !,"No admission for ",XD
GOTO EX
+1 ;
INP ;MAS VERSIONS less than 5.0
+1 NEW I,X
DO INP^VADPT
if VAIN(1)=""
QUIT
SET XD=$PIECE($PIECE(VAIN(7),U),".")
DO DD
SET AD=XD
SET XD=$SELECT($DATA(^DPT(DFN,"DA",VAIN(1),1)):$PIECE(^(1),U),1:"")
DO DD
QUIT
+2 ;
NOKEO ;COMPUTED EXPRESSION for NOK (160,.214)
+1 ;Displays K-NAME OF PRIMARY NOK (2,.211) and
+2 ; K-RELATIONSHIP TO PATIENT (2,.212)
+3 NEW RCDT
+4 IF $DATA(^ONCO(160,D0,0))
SET RCDT=^(0)
IF $PIECE(RCDT,";",2)["DPT"
IF $DATA(^DPT($PIECE(RCDT,";",1),.21))
WRITE $PIECE(^(.21),U)_" ("_$PIECE(^(.21),U,2)_")"
+5 QUIT
+6 ;
SAD ;COMPUTED EXPRESSION for SUSPENSE ADMIT DATE (160,33.1)
+1 DO SUS
SET X=$SELECT($DATA(XAD):XAD,1:"")
+2 GOTO EX
+3 ;
SDD ;COMPUTED EXPRESSION for SUSPENSE DISCHARGE DATE (160,33.2)
+1 DO SUS
SET X=$SELECT($DATA(XDD):XDD,1:"")
+2 GOTO EX
+3 ;
SEC ;COMPUTED EXPRESSION for SUSPENSE EPISODE OF CARE (160,33.3)
+1 DO SUS
SET X=""
if SD=""
GOTO EX
IF '$DATA(AD)
SET XD=SD
GOTO NO
+2 SET XD=$SELECT($DATA(XD):XD,1:"")
GOTO WE
+3 ;
SUS ;SUSPENSE EPISODE OF CARE
+1 SET XD0=D0
SET SD=""
+2 SET SDIEN=$ORDER(^ONCO(160,XD0,"SUS","C",DUZ(2),""))
+3 IF SDIEN'=""
SET SD=$PIECE($GET(^ONCO(160,XD0,"SUS",SDIEN,0)),"^",1)
+4 if SD=""
QUIT
DO VP
if OP=""
QUIT
+5 SET VAIP("D")=SD
DO IN5
+6 QUIT
+7 ;
LEC ;COMPUTED EXPRESSION for LAST EPISODE of CARE (160,34)
+1 DO LST
+2 IF '$DATA(AD)
WRITE "No admission data"
GOTO EX
+3 IF $DATA(XD)
IF XD'=""
WRITE "Admission: ",AD_" Discharge: "_XD
GOTO EX
+4 WRITE "Admission: "_AD_" (Active)"
GOTO EX
+5 ;
LAD ;COMPUTED EXPRESSION for LAST ADMIT DATE (160,34.1)
+1 DO LST
SET X=$SELECT($DATA(AD):AD,1:"")
+2 GOTO EX
+3 ;
LDD ;COMPUTED EXPRESSION for LAST DISCHARGE DATE (160,34.2)
+1 DO LST
SET X=$SELECT($DATA(XD):XD,1:"")
+2 GOTO EX
+3 ;
LST ;Get ADMISSION and DISCHARGE data
+1 SET XD0=D0
DO VP
if OP=""
GOTO EX
+2 SET VAIP("D")="L"
+3 DO IN5
+4 QUIT
+5 ;
VP ;Resolve NAME (160,.01) variable pointer
+1 SET OP=$SELECT($DATA(^ONCO(160,XD0,0)):$PIECE(^(0),U),1:"")
+2 SET DFN=$PIECE(OP,";",1)
+3 SET OF=$PIECE(OP,";",2)
+4 SET OP=$SELECT(OF="LRT(67,":"",1:OP)
+5 QUIT
+6 ;
IN5 ;Call IN5^VADPT (Inpatient Data [v5.0 and above])
+1 NEW X
+2 DO IN5^VADPT
if VAIP(1)=""
QUIT
+3 SET XD=$PIECE(VAIP(13,1),".")
DO DD
SET AD=XD
+4 SET XD=$PIECE(VAIP(17,1),".")
DO DD
SET XD=XD
+5 QUIT
+6 ;
DD ;Format date as mm/dd/yy
+1 SET XD=$SELECT(XD="":XD,1:$EXTRACT(XD,4,5)_"/"_$EXTRACT(XD,6,7)_"/"_$EXTRACT(XD,2,3))
+2 QUIT
+3 ;
EX ;Exit
+1 KILL AD,CSZ,DFN,NOK,OF,ONCO,ONCOAD,ONCODD,OP,RCDT,SD,SDIEN,SP,ST
+2 KILL VAERR,VAIN,VAIP,VAINDT,VAOA,XAD,XD,XDD,XX,XD0
+3 QUIT
+4 ;
CLEANUP ;Cleanup
+1 KILL D0
