- ONCOANC2 ;Hines OIFO/GWB - BUILDS DATA ARRAY FOR NCDB CALL FOR DATA ;7/20/93 10:38
- ;;2.2;ONCOLOGY;**1**;Jul 31, 2013;Build 8
- AASTUM ; TUMOR DATA
- S AASEQ=$P(AAS1655("N0"),U,6)
- I AASEQ?2A,"^AA^BB^CC^DD^EE^FF^GG^HH^II^XX^"'[("^"_AASEQ_"^") S AASEQ="99"
- I AASEQ=""!(AASEQ<0)!(AASEQ>99) S AASEQ="99"
- S:$L(AASEQ)<2 AASEQ=$E(AASZERO,1,2-$L(AASEQ))_AASEQ
- S AASX=$P(AAS1655("N0"),U,16) X AASDTCV S AASDXDT=AASX
- S:AASAY>89 AASPS=$$ONCOPS($P(AAS1655("N2"),U))
- ;The following is the old logic for Primary Site extraction
- I AASAY<90 D
- .S AASPS=$P(AAS1655("N2"),U,29),AASPS=$S('$L(AASPS):1999,AASPS<1400!(AASPS>1999):1999,1:AASPS)
- .S:"."[AASPS AASPS=$P(AASPS,".")
- S AASLAT=$P(AAS1655("N2"),U,8),AASLAT=$S(AASLAT=""!(AASLAT<0)!(AASLAT>4):0,1:AASLAT)
- S AASMHIS=$P(AAS1655("N2"),U,30) I AASMHIS'="" S:$L(AASMHIS)<5 AASMHIS=$E(AASZERO,1,5-$L(AASMHIS))_AASMHIS
- S:AASMHIS="" AASMHIS=$P(AAS1655("N2"),U,3) S:$L(AASMHIS)<5 AASMHIS=$E(AASZERO,1,5-$L(AASMHIS))_AASMHIS
- S:$L(AASMHIS)>5 AASMHIS=$E(AASMHIS,1,5)
- S AASGDIF=$P(AAS1655("N2"),U,5) S AASGDIF=$S(AASGDIF=""!(AASGDIF<0)!(AASGDIF>7):9,1:AASGDIF)
- S (AASITC,AASMORC)=9
- S AASDIA=$P(AAS1655("N2"),U,6) S AASDIA=$S(AASDIA=""!(AASDIA<1)!(AASDIA=3)!(AASDIA>9):9,1:AASDIA)
- S AASRPT=$P(AAS1655("N0"),U,10)
- S AASRPT=$S(AASRPT=2:1,AASRPT>7!(AASRPT=""):" ",1:AASRPT)
- S ^TMP($J,D0,149)=^TMP($J,D0,149)_AASEQ_AASDXDT_AASPS_AASLAT_AASMHIS_AASGDIF_AASITC_AASITC_AASMORC_$E(AASBLNK,1,1)_AASDIA_AASRPT_AASACYR_$E(AASBLNK,1,4)_$E(AASZERO,1,2)_AASDXH
- AASHSP ; HOSPITAL-SPECIFIC DATA
- S AASACCH=$P(AAS1655("N0"),U,5) S AASACCH=$S(AASACCH="":"000000",$L(AASACCH)<6:$E(AASZERO,1,6-$L(AASACCH))_AASACCH,1:AASACCH)
- S AASX=$P(AAS1655("N0"),U,8) X AASDTCV S AASHAD=AASX
- S AASX=$P(AAS1655("N0"),U,9) X AASDTCV S AASHDD=AASX
- S AASRHSR=$P(AAS1655("N3"),U,38) S AASRHSR=$S(AASRHSR="":"00",1:AASRHSR)
- S AASRHRA=$P(AAS1655("N3"),U,6) S AASRHRA=$S(AASRHRA=""!(AASRHRA<0):" ",AASRHRA=6:" ",AASRHRA>9:" ",1:AASRHRA)
- S AASRXCH=$P(AAS1655("N3"),U,13) S AASRXCH=$S(AASRXCH=""!(AASRXCH<0)!(AASRXCH>9):" ",AASRXCH>3&(AASRXCH<7):" ",1:AASRXCH)
- S AASRST=$P(AAS1655("N3"),U,16) S AASRST=$S(AASRST=""!(AASRST<0)!(AASRST>9):" ",AASRST>3&(AASRST<7):" ",1:AASRST)
- S AASRXBR=$P(AAS1655("N3"),U,19)
- S:AASRXBR'="" AASRXBR=$P($G(^ONCO(160.5,AASRXBR,0)),U,1)
- S AASRXBR=$S(AASRXBR=""!(AASRXBR<0)!(AASRXBR>9):" ",AASRXBR>1&(AASRXBR<7):" ",1:AASRXBR)
- S AASROC=$P(AAS1655("N3"),U,25) S AASROC=$S(AASROC=""!(AASROC<0)!(AASROC>9):" ",AASROC>3&(AASROC<6):" ",1:AASROC)
- S ^TMP($J,D0,225)=AASACCH_" "_AASHAD_AASHDD_AASCASE_AASRHSR_AASRHRA_AASRXCH_AASRST_AASRXBR_AASROC
- G AASTEOD^ONCOANC1
- Q
- ONCOPS(TMP1) ;
- N TMP
- S TMP=$G(^ONCO(164,+TMP1,0))
- S TMP=$P(TMP,U,2)
- Q $S(TMP'?1"C"2N1"."1N:" ",1:$P(TMP,".")_$P(TMP,".",2))
- TPREP ;
- N NAME,DATA,NEXT,REQ
- D:PG=0 HEAD
- F NEXT=1:1 D PTNEXT(.NAME,.DATA,.NEXT,.REQ) Q:NEXT=0 Q:$D(ONCOUT) D
- .W !,NAME,?50,DATA X ONCOFF Q:$D(ONCOUT)
- Q:$D(ONCOUT) I $Y>3 D CFORM
- Q
- REQREP ;
- N NAME,DATA,NEXT,REQ,RECID
- F NEXT=1:1 D PTNEXT(.NAME,.DATA,.NEXT,.REQ) Q:+NEXT=0 Q:$D(ONCOUT) D:REQ'=""
- .I '$D(RECID) S RECID=$$GDATA(2,6) X ONCOFF Q:$D(ONCOUT) D:PG=0 HEAD W !,"Patient ID",?50,RECID,!,"Primary Site",?50,$$GDATA(119,122)
- .W !,NAME,?50,"******" X ONCOFF Q:$D(ONCOUT) ;DATA
- I $D(RECID) S ONCOECNT=ONCOECNT+1 W ! X ONCOFF Q:$D(ONCOUT) I $Y>3 D CFORM
- Q
- PTNEXT(NAME,DATA,NEXT,REQ) ;
- N START,END,TMP
- S TMP=$TEXT(DATA+NEXT^ONCOANCF)
- I TMP'="" D
- .S NAME=$P($P(TMP,";;",2),U),START=$P(TMP,U,2),END=$P(TMP,U,3)
- .S DATA=$$GDATA(START,END),REQ=$P(TMP,U,4) D:REQ[":" CHKOR(.REQ)
- .S REQ=$S(REQ="":"",$E(DATA,1,$L(DATA))=$E(AASBLNK,1,$L(DATA)):1,1:"")
- S:TMP="" NEXT=0
- Q
- CHKOR(REQ) ;
- N START,END,DATA1
- S START=$P($P(REQ,":",2),","),END=$P($P(REQ,":",2),",",2)
- S DATA1=$$GDATA(START,END)
- S REQ=$S($E(DATA1,1,$L(DATA1))=$E(AASBLNK,1,$L(DATA1)):1,1:"")
- Q
- GDATA(START,END) ;
- N NODE,BASE S (BASE,NODE)=0
- F S NODE=$O(^TMP($J,D0,NODE)) Q:+NODE=0 Q:(((BASE+$L(^(NODE)))>END)!(BASE+$L(^(NODE))=END)) S BASE=BASE+$L(^(NODE))
- Q $S(+NODE=0:" ",1:$E(^TMP($J,D0,NODE),START-BASE,END-BASE))
- CFORM ;
- S DN=1,ONCOY="" R:IOST["C-" !!,"Press Return to Continue, '^' to escape: ",ONCOY:DTIME S:'$T ONCOY=U S:ONCOY=U ONCOUT=1,DN=0 Q:$D(ONCOUT) D:DN HEAD^ONCOANC2 K ONCOY
- Q
- HEAD ;
- S PG=PG+1 W @IOF,!,"Pg. "_PG,?79-$L(" Oncology ACOS Report "),"Oncology ACOS Report"
- I (PG>1),(IOST["C-") W ! Q
- W:$D(ONCOREP) !,$$HEDSTAR("Oncology ACOS Report ",77)
- W:$D(ONCOREQ) !,$$HEDSTAR("Oncology ACOS Required data Report ",77)
- N FFF S $P(FFF,"- ",40)="- " W !,FFF,!
- Q
- HEDSTAR(X,X1) ; surround text string X with asterisks to length X1
- N Y1
- S (TY,Y1)="",$P(Y1," ",X1-$L(X)\2-1)=" ",TY=Y1_" "_X_" "
- F I=$L(TY):1:X1 S TY=TY_" "
- Q TY
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HONCOANC2 4761 printed Feb 18, 2025@23:50:51 Page 2
- ONCOANC2 ;Hines OIFO/GWB - BUILDS DATA ARRAY FOR NCDB CALL FOR DATA ;7/20/93 10:38
- +1 ;;2.2;ONCOLOGY;**1**;Jul 31, 2013;Build 8
- AASTUM ; TUMOR DATA
- +1 SET AASEQ=$PIECE(AAS1655("N0"),U,6)
- +2 IF AASEQ?2A
- IF "^AA^BB^CC^DD^EE^FF^GG^HH^II^XX^"'[("^"_AASEQ_"^")
- SET AASEQ="99"
- +3 IF AASEQ=""!(AASEQ<0)!(AASEQ>99)
- SET AASEQ="99"
- +4 if $LENGTH(AASEQ)<2
- SET AASEQ=$EXTRACT(AASZERO,1,2-$LENGTH(AASEQ))_AASEQ
- +5 SET AASX=$PIECE(AAS1655("N0"),U,16)
- XECUTE AASDTCV
- SET AASDXDT=AASX
- +6 if AASAY>89
- SET AASPS=$$ONCOPS($PIECE(AAS1655("N2"),U))
- +7 ;The following is the old logic for Primary Site extraction
- +8 IF AASAY<90
- Begin DoDot:1
- +9 SET AASPS=$PIECE(AAS1655("N2"),U,29)
- SET AASPS=$SELECT('$LENGTH(AASPS):1999,AASPS<1400!(AASPS>1999):1999,1:AASPS)
- +10 if "."[AASPS
- SET AASPS=$PIECE(AASPS,".")
- End DoDot:1
- +11 SET AASLAT=$PIECE(AAS1655("N2"),U,8)
- SET AASLAT=$SELECT(AASLAT=""!(AASLAT<0)!(AASLAT>4):0,1:AASLAT)
- +12 SET AASMHIS=$PIECE(AAS1655("N2"),U,30)
- IF AASMHIS'=""
- if $LENGTH(AASMHIS)<5
- SET AASMHIS=$EXTRACT(AASZERO,1,5-$LENGTH(AASMHIS))_AASMHIS
- +13 if AASMHIS=""
- SET AASMHIS=$PIECE(AAS1655("N2"),U,3)
- if $LENGTH(AASMHIS)<5
- SET AASMHIS=$EXTRACT(AASZERO,1,5-$LENGTH(AASMHIS))_AASMHIS
- +14 if $LENGTH(AASMHIS)>5
- SET AASMHIS=$EXTRACT(AASMHIS,1,5)
- +15 SET AASGDIF=$PIECE(AAS1655("N2"),U,5)
- SET AASGDIF=$SELECT(AASGDIF=""!(AASGDIF<0)!(AASGDIF>7):9,1:AASGDIF)
- +16 SET (AASITC,AASMORC)=9
- +17 SET AASDIA=$PIECE(AAS1655("N2"),U,6)
- SET AASDIA=$SELECT(AASDIA=""!(AASDIA<1)!(AASDIA=3)!(AASDIA>9):9,1:AASDIA)
- +18 SET AASRPT=$PIECE(AAS1655("N0"),U,10)
- +19 SET AASRPT=$SELECT(AASRPT=2:1,AASRPT>7!(AASRPT=""):" ",1:AASRPT)
- +20 SET ^TMP($JOB,D0,149)=^TMP($JOB,D0,149)_AASEQ_AASDXDT_AASPS_AASLAT_AASMHIS_AASGDIF_AASITC_AASITC_AASMORC_$EXTRACT(AASBLNK,1,1)_AASDIA_AASRPT_AASACYR_$EXTRACT(AASBLNK,1,4)_$EXTRACT(AASZERO,1,2)_AASDXH
- AASHSP ; HOSPITAL-SPECIFIC DATA
- +1 SET AASACCH=$PIECE(AAS1655("N0"),U,5)
- SET AASACCH=$SELECT(AASACCH="":"000000",$LENGTH(AASACCH)<6:$EXTRACT(AASZERO,1,6-$LENGTH(AASACCH))_AASACCH,1:AASACCH)
- +2 SET AASX=$PIECE(AAS1655("N0"),U,8)
- XECUTE AASDTCV
- SET AASHAD=AASX
- +3 SET AASX=$PIECE(AAS1655("N0"),U,9)
- XECUTE AASDTCV
- SET AASHDD=AASX
- +4 SET AASRHSR=$PIECE(AAS1655("N3"),U,38)
- SET AASRHSR=$SELECT(AASRHSR="":"00",1:AASRHSR)
- +5 SET AASRHRA=$PIECE(AAS1655("N3"),U,6)
- SET AASRHRA=$SELECT(AASRHRA=""!(AASRHRA<0):" ",AASRHRA=6:" ",AASRHRA>9:" ",1:AASRHRA)
- +6 SET AASRXCH=$PIECE(AAS1655("N3"),U,13)
- SET AASRXCH=$SELECT(AASRXCH=""!(AASRXCH<0)!(AASRXCH>9):" ",AASRXCH>3&(AASRXCH<7):" ",1:AASRXCH)
- +7 SET AASRST=$PIECE(AAS1655("N3"),U,16)
- SET AASRST=$SELECT(AASRST=""!(AASRST<0)!(AASRST>9):" ",AASRST>3&(AASRST<7):" ",1:AASRST)
- +8 SET AASRXBR=$PIECE(AAS1655("N3"),U,19)
- +9 if AASRXBR'=""
- SET AASRXBR=$PIECE($GET(^ONCO(160.5,AASRXBR,0)),U,1)
- +10 SET AASRXBR=$SELECT(AASRXBR=""!(AASRXBR<0)!(AASRXBR>9):" ",AASRXBR>1&(AASRXBR<7):" ",1:AASRXBR)
- +11 SET AASROC=$PIECE(AAS1655("N3"),U,25)
- SET AASROC=$SELECT(AASROC=""!(AASROC<0)!(AASROC>9):" ",AASROC>3&(AASROC<6):" ",1:AASROC)
- +12 SET ^TMP($JOB,D0,225)=AASACCH_" "_AASHAD_AASHDD_AASCASE_AASRHSR_AASRHRA_AASRXCH_AASRST_AASRXBR_AASROC
- +13 GOTO AASTEOD^ONCOANC1
- +14 QUIT
- ONCOPS(TMP1) ;
- +1 NEW TMP
- +2 SET TMP=$GET(^ONCO(164,+TMP1,0))
- +3 SET TMP=$PIECE(TMP,U,2)
- +4 QUIT $SELECT(TMP'?1"C"2N1"."1N:" ",1:$PIECE(TMP,".")_$PIECE(TMP,".",2))
- TPREP ;
- +1 NEW NAME,DATA,NEXT,REQ
- +2 if PG=0
- DO HEAD
- +3 FOR NEXT=1:1
- DO PTNEXT(.NAME,.DATA,.NEXT,.REQ)
- if NEXT=0
- QUIT
- if $DATA(ONCOUT)
- QUIT
- Begin DoDot:1
- +4 WRITE !,NAME,?50,DATA
- XECUTE ONCOFF
- if $DATA(ONCOUT)
- QUIT
- End DoDot:1
- +5 if $DATA(ONCOUT)
- QUIT
- IF $Y>3
- DO CFORM
- +6 QUIT
- REQREP ;
- +1 NEW NAME,DATA,NEXT,REQ,RECID
- +2 FOR NEXT=1:1
- DO PTNEXT(.NAME,.DATA,.NEXT,.REQ)
- if +NEXT=0
- QUIT
- if $DATA(ONCOUT)
- QUIT
- if REQ'=""
- Begin DoDot:1
- +3 IF '$DATA(RECID)
- SET RECID=$$GDATA(2,6)
- XECUTE ONCOFF
- if $DATA(ONCOUT)
- QUIT
- if PG=0
- DO HEAD
- WRITE !,"Patient ID",?50,RECID,!,"Primary Site",?50,$$GDATA(119,122)
- +4 ;DATA
- WRITE !,NAME,?50,"******"
- XECUTE ONCOFF
- if $DATA(ONCOUT)
- QUIT
- End DoDot:1
- +5 IF $DATA(RECID)
- SET ONCOECNT=ONCOECNT+1
- WRITE !
- XECUTE ONCOFF
- if $DATA(ONCOUT)
- QUIT
- IF $Y>3
- DO CFORM
- +6 QUIT
- PTNEXT(NAME,DATA,NEXT,REQ) ;
- +1 NEW START,END,TMP
- +2 SET TMP=$TEXT(DATA+NEXT^ONCOANCF)
- +3 IF TMP'=""
- Begin DoDot:1
- +4 SET NAME=$PIECE($PIECE(TMP,";;",2),U)
- SET START=$PIECE(TMP,U,2)
- SET END=$PIECE(TMP,U,3)
- +5 SET DATA=$$GDATA(START,END)
- SET REQ=$PIECE(TMP,U,4)
- if REQ["
- DO CHKOR(.REQ)
- +6 SET REQ=$SELECT(REQ="":"",$EXTRACT(DATA,1,$LENGTH(DATA))=$EXTRACT(AASBLNK,1,$LENGTH(DATA)):1,1:"")
- End DoDot:1
- +7 if TMP=""
- SET NEXT=0
- +8 QUIT
- CHKOR(REQ) ;
- +1 NEW START,END,DATA1
- +2 SET START=$PIECE($PIECE(REQ,":",2),",")
- SET END=$PIECE($PIECE(REQ,":",2),",",2)
- +3 SET DATA1=$$GDATA(START,END)
- +4 SET REQ=$SELECT($EXTRACT(DATA1,1,$LENGTH(DATA1))=$EXTRACT(AASBLNK,1,$LENGTH(DATA1)):1,1:"")
- +5 QUIT
- GDATA(START,END) ;
- +1 NEW NODE,BASE
- SET (BASE,NODE)=0
- +2 FOR
- SET NODE=$ORDER(^TMP($JOB,D0,NODE))
- if +NODE=0
- QUIT
- if (((BASE+$LENGTH(^(NODE)))>END)!(BASE+$LENGTH(^(NODE))=END))
- QUIT
- SET BASE=BASE+$LENGTH(^(NODE))
- +3 QUIT $SELECT(+NODE=0:" ",1:$EXTRACT(^TMP($JOB,D0,NODE),START-BASE,END-BASE))
- CFORM ;
- +1 SET DN=1
- SET ONCOY=""
- if IOST["C-"
- READ !!,"Press Return to Continue, '^' to escape: ",ONCOY:DTIME
- if '$TEST
- SET ONCOY=U
- if ONCOY=U
- SET ONCOUT=1
- SET DN=0
- if $DATA(ONCOUT)
- QUIT
- if DN
- DO HEAD^ONCOANC2
- KILL ONCOY
- +2 QUIT
- HEAD ;
- +1 SET PG=PG+1
- WRITE @IOF,!,"Pg. "_PG,?79-$LENGTH(" Oncology ACOS Report "),"Oncology ACOS Report"
- +2 IF (PG>1)
- IF (IOST["C-")
- WRITE !
- QUIT
- +3 if $DATA(ONCOREP)
- WRITE !,$$HEDSTAR("Oncology ACOS Report ",77)
- +4 if $DATA(ONCOREQ)
- WRITE !,$$HEDSTAR("Oncology ACOS Required data Report ",77)
- +5 NEW FFF
- SET $PIECE(FFF,"- ",40)="- "
- WRITE !,FFF,!
- +6 QUIT
- HEDSTAR(X,X1) ; surround text string X with asterisks to length X1
- +1 NEW Y1
- +2 SET (TY,Y1)=""
- SET $PIECE(Y1," ",X1-$LENGTH(X)\2-1)=" "
- SET TY=Y1_" "_X_" "
- +3 FOR I=$LENGTH(TY):1:X1
- SET TY=TY_" "
- +4 QUIT TY