- 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 Jan 18, 2025@03:25:50 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