- ONCOANC4 ;Hines OIFO/GWB - ACOS DATA TAPE UTILITY FUNCTIONS ;7/20/93
- ;;2.2;ONCOLOGY;**1**;Jul 31, 2013;Build 8
- ;
- AASDC(YYYMMDD,ZERO) ; CONVERTS YYYMMDD TO MMDDCCYY
- ; returns blank input as zeros if ZERO defined, else blanks
- ;
- IF (YYYMMDD'="")&(YYYMMDD'?6"0") D I 1 ; non-null input - convert
- . S MMDDCCYY=$E(YYYMMDD,4,5)_$E(YYYMMDD,6,7)_(1700+$E(YYYMMDD,1,3))
- . I $E(MMDDCCYY,1,2)="00" S MMDDCCYY=99_$E(MMDDCCYY,3,8)
- . I $E(MMDDCCYY,3,4)="00" S MMDDCCYY=$E(MMDDCCYY,1,2)_99_$E(MMDDCCYY,5,8)
- . Q
- ELSE D ; null input - return blanks or zeros
- . I '$D(ZERO) S MMDDCCYY=$J("",8) ; blanks
- . E S MMDDCCYY="00000000" ; zeros
- . Q
- ;END IF
- ;
- QUIT MMDDCCYY
- INIT(D0,DATE,SURG,RAD,CHEM,HORM,BIO,OCO,NUMBER) ;Subsequent Therapies
- N TMP,CNT,RCNT S CNT=0,DATE=""
- F S CNT=$O(^ONCO(165.5,D0,4,CNT)) Q:CNT'?1N.N D
- .S TMP($P(^ONCO(165.5,D0,4,CNT,0),U))=^(0)
- .S TMP($P(^ONCO(165.5,D0,4,CNT,0),U),3)=$S('$D(^ONCO(165.5,D0,4,CNT,3)):"",1:^(3))
- F RCNT=1:1:NUMBER S DATE=$O(TMP(DATE)) Q:DATE=""
- D @$S(DATE="":"NOENT",1:"ENTREE")
- S DATE=$$AASDC(DATE)
- Q
- NOENT ; 'NUMBER' Subsequent therapy does not exist
- S SURG=" "
- S (RAD,CHEM,HORM,BIO,OCO)=" ",NUMBER=0
- Q
- ENTREE ;
- S SURG=$P(TMP(DATE),U,4) S SURG=$S($G(SURG):SURG,1:" ")
- S:($L(SURG)<2) SURG="0"_SURG
- S RAD=$P(TMP(DATE),U,5) S RAD=$S($G(RAD):RAD,1:" ")
- S CHEM=$P(TMP(DATE),U,6) S CHEM=$S($G(CHEM):CHEM,1:" ")
- S HORM=$P(TMP(DATE),U,7) S HORM=$S($G(HORM):HORM,1:" ")
- S BIO=$P(TMP(DATE,3),U,19) S BIO=$S($G(BIO):BIO,1:" ")
- S OCO=$P(TMP(DATE),U,9) S OCO=$S($G(OCO):OCO,1:" ")
- Q
- RSAR ;RACE,SEX,AGE,RELIGION
- S AASRAC=$S($P(AAS160("N0"),U,6)]"":$P(AAS160("N0"),U,6),1:99)
- S AASRAC=$S(AASRAC>13&(AASRAC<20)!(AASRAC>22&(AASRAC<25))!(AASRAC>28&(AASRAC<30))!(AASRAC>32&(AASRAC<96)):99,1:AASRAC)
- S AASRAC=$S(AASRAC<1!(AASRAC>99):99,1:AASRAC)
- S:$L(AASRAC)<2 AASRAC=$E(AASZERO,1,2-$L(AASRAC))_AASRAC
- S AASRCS=3,AASPAN=$P(AAS160("N0"),U,7),AASPAN=$S(AASPAN=""!(AASPAN<0)!(AASPAN>9):9,AASPAN>6&(AASPAN<9):9,1:AASPAN)
- S AASEX=$P(AAS160("N0"),U,8),AASEX=$S(AASEX=""!(AASEX<1)!(AASEX>9):9,AASEX>4&(AASEX<9):9,1:AASEX)
- D AGE^ONCOCOM S AASAGE=$S(X=""!(X<0)!(X>999):"000",1:X)
- S:$L(AASAGE)<3 AASAGE=$E(AASZERO,1,3-$L(AASAGE))_AASAGE
- S AASX=$S(+$P(AASDPT,U,3):$P(AASDPT,U,3),1:"") X AASDTCV S AASDOB=AASX
- S AASPOB=$S($P(AAS160("N0"),U,5)'="":$P(AAS160("N0"),U,5),1:999)
- S:$L(AASPOB)<3 AASPOB=$E(AASZERO,1,3-$L(AASPOB))_AASPOB
- S AASREL=99
- S ^TMP($J,D0,76)=^TMP($J,D0,76)_AASMS_AASRAC_AASRCS_AASRCS_AASPAN_AASEX_AASAGE_AASDOB
- S ^TMP($J,D0,149)=AASPOB_AASREL_$E(AASBLNK,1,26)
- Q
- NAME ;First, and Last Names, Middle initials, and SSN Extracted
- S AASNM=$P(PD0,U),AASFSSN=$P(PD0,U,9),$P(AASNMBLK," ",16)=""
- S:AASFSSN'?9N AASFSSN=999999999
- S AASNMF=$TR($P(AASNM,",",2),".,-'_")
- S AASNML=$TR($P(AASNM,","),"., -'_"),AASNML=$E(AASNML_AASNMBLK,1,15)
- S AASNMM=$E($P(AASNMF," ",2),1) S:AASNMM'?1U AASNMM=" "
- S AASNMF=$P(AASNMF," "),AASNMF=$E(AASNMF_AASNMBLK,1,14)
- S $P(AASNMBLK," ",80)=""
- S ^TMP($J,D0,628)=$E(AASNMBLK,1,78),^TMP($J,D0,706)=$E(AASNMBLK,1,78)
- S ^TMP($J,D0,784)=$E(AASNMBLK,1,78),^TMP($J,D0,850)=$E(AASNMBLK,1,66)
- S ^TMP($J,D0,925)=AASNML_AASNMF_AASNMM_$E(AASNMBLK,1,44)
- S AASDXCIT=$E($P(AAS1655("N1"),U),1,25)
- S AASDXCIT=AASDXCIT_$E(AASNMBLK,1,25-$L(AASDXCIT))
- S ^TMP($J,D0,1000)=$E(AASNMBLK,1,32)_AASFSSN_AASDXCIT_$E(AASNMBLK,1,10)
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HONCOANC4 3400 printed Feb 18, 2025@23:50:53 Page 2
- ONCOANC4 ;Hines OIFO/GWB - ACOS DATA TAPE UTILITY FUNCTIONS ;7/20/93
- +1 ;;2.2;ONCOLOGY;**1**;Jul 31, 2013;Build 8
- +2 ;
- AASDC(YYYMMDD,ZERO) ; CONVERTS YYYMMDD TO MMDDCCYY
- +1 ; returns blank input as zeros if ZERO defined, else blanks
- +2 ;
- +3 ; non-null input - convert
- IF (YYYMMDD'="")&(YYYMMDD'?6"0")
- Begin DoDot:1
- +4 SET MMDDCCYY=$EXTRACT(YYYMMDD,4,5)_$EXTRACT(YYYMMDD,6,7)_(1700+$EXTRACT(YYYMMDD,1,3))
- +5 IF $EXTRACT(MMDDCCYY,1,2)="00"
- SET MMDDCCYY=99_$EXTRACT(MMDDCCYY,3,8)
- +6 IF $EXTRACT(MMDDCCYY,3,4)="00"
- SET MMDDCCYY=$EXTRACT(MMDDCCYY,1,2)_99_$EXTRACT(MMDDCCYY,5,8)
- +7 QUIT
- End DoDot:1
- IF 1
- +8 ; null input - return blanks or zeros
- IF '$TEST
- Begin DoDot:1
- +9 ; blanks
- IF '$DATA(ZERO)
- SET MMDDCCYY=$JUSTIFY("",8)
- +10 ; zeros
- IF '$TEST
- SET MMDDCCYY="00000000"
- +11 QUIT
- End DoDot:1
- +12 ;END IF
- +13 ;
- +14 QUIT MMDDCCYY
- INIT(D0,DATE,SURG,RAD,CHEM,HORM,BIO,OCO,NUMBER) ;Subsequent Therapies
- +1 NEW TMP,CNT,RCNT
- SET CNT=0
- SET DATE=""
- +2 FOR
- SET CNT=$ORDER(^ONCO(165.5,D0,4,CNT))
- if CNT'?1N.N
- QUIT
- Begin DoDot:1
- +3 SET TMP($PIECE(^ONCO(165.5,D0,4,CNT,0),U))=^(0)
- +4 SET TMP($PIECE(^ONCO(165.5,D0,4,CNT,0),U),3)=$SELECT('$DATA(^ONCO(165.5,D0,4,CNT,3)):"",1:^(3))
- End DoDot:1
- +5 FOR RCNT=1:1:NUMBER
- SET DATE=$ORDER(TMP(DATE))
- if DATE=""
- QUIT
- +6 DO @$SELECT(DATE="":"NOENT",1:"ENTREE")
- +7 SET DATE=$$AASDC(DATE)
- +8 QUIT
- NOENT ; 'NUMBER' Subsequent therapy does not exist
- +1 SET SURG=" "
- +2 SET (RAD,CHEM,HORM,BIO,OCO)=" "
- SET NUMBER=0
- +3 QUIT
- ENTREE ;
- +1 SET SURG=$PIECE(TMP(DATE),U,4)
- SET SURG=$SELECT($GET(SURG):SURG,1:" ")
- +2 if ($LENGTH(SURG)<2)
- SET SURG="0"_SURG
- +3 SET RAD=$PIECE(TMP(DATE),U,5)
- SET RAD=$SELECT($GET(RAD):RAD,1:" ")
- +4 SET CHEM=$PIECE(TMP(DATE),U,6)
- SET CHEM=$SELECT($GET(CHEM):CHEM,1:" ")
- +5 SET HORM=$PIECE(TMP(DATE),U,7)
- SET HORM=$SELECT($GET(HORM):HORM,1:" ")
- +6 SET BIO=$PIECE(TMP(DATE,3),U,19)
- SET BIO=$SELECT($GET(BIO):BIO,1:" ")
- +7 SET OCO=$PIECE(TMP(DATE),U,9)
- SET OCO=$SELECT($GET(OCO):OCO,1:" ")
- +8 QUIT
- RSAR ;RACE,SEX,AGE,RELIGION
- +1 SET AASRAC=$SELECT($PIECE(AAS160("N0"),U,6)]"":$PIECE(AAS160("N0"),U,6),1:99)
- +2 SET AASRAC=$SELECT(AASRAC>13&(AASRAC<20)!(AASRAC>22&(AASRAC<25))!(AASRAC>28&(AASRAC<30))!(AASRAC>32&(AASRAC<96)):99,1:AASRAC)
- +3 SET AASRAC=$SELECT(AASRAC<1!(AASRAC>99):99,1:AASRAC)
- +4 if $LENGTH(AASRAC)<2
- SET AASRAC=$EXTRACT(AASZERO,1,2-$LENGTH(AASRAC))_AASRAC
- +5 SET AASRCS=3
- SET AASPAN=$PIECE(AAS160("N0"),U,7)
- SET AASPAN=$SELECT(AASPAN=""!(AASPAN<0)!(AASPAN>9):9,AASPAN>6&(AASPAN<9):9,1:AASPAN)
- +6 SET AASEX=$PIECE(AAS160("N0"),U,8)
- SET AASEX=$SELECT(AASEX=""!(AASEX<1)!(AASEX>9):9,AASEX>4&(AASEX<9):9,1:AASEX)
- +7 DO AGE^ONCOCOM
- SET AASAGE=$SELECT(X=""!(X<0)!(X>999):"000",1:X)
- +8 if $LENGTH(AASAGE)<3
- SET AASAGE=$EXTRACT(AASZERO,1,3-$LENGTH(AASAGE))_AASAGE
- +9 SET AASX=$SELECT(+$PIECE(AASDPT,U,3):$PIECE(AASDPT,U,3),1:"")
- XECUTE AASDTCV
- SET AASDOB=AASX
- +10 SET AASPOB=$SELECT($PIECE(AAS160("N0"),U,5)'="":$PIECE(AAS160("N0"),U,5),1:999)
- +11 if $LENGTH(AASPOB)<3
- SET AASPOB=$EXTRACT(AASZERO,1,3-$LENGTH(AASPOB))_AASPOB
- +12 SET AASREL=99
- +13 SET ^TMP($JOB,D0,76)=^TMP($JOB,D0,76)_AASMS_AASRAC_AASRCS_AASRCS_AASPAN_AASEX_AASAGE_AASDOB
- +14 SET ^TMP($JOB,D0,149)=AASPOB_AASREL_$EXTRACT(AASBLNK,1,26)
- +15 QUIT
- NAME ;First, and Last Names, Middle initials, and SSN Extracted
- +1 SET AASNM=$PIECE(PD0,U)
- SET AASFSSN=$PIECE(PD0,U,9)
- SET $PIECE(AASNMBLK," ",16)=""
- +2 if AASFSSN'?9N
- SET AASFSSN=999999999
- +3 SET AASNMF=$TRANSLATE($PIECE(AASNM,",",2),".,-'_")
- +4 SET AASNML=$TRANSLATE($PIECE(AASNM,","),"., -'_")
- SET AASNML=$EXTRACT(AASNML_AASNMBLK,1,15)
- +5 SET AASNMM=$EXTRACT($PIECE(AASNMF," ",2),1)
- if AASNMM'?1U
- SET AASNMM=" "
- +6 SET AASNMF=$PIECE(AASNMF," ")
- SET AASNMF=$EXTRACT(AASNMF_AASNMBLK,1,14)
- +7 SET $PIECE(AASNMBLK," ",80)=""
- +8 SET ^TMP($JOB,D0,628)=$EXTRACT(AASNMBLK,1,78)
- SET ^TMP($JOB,D0,706)=$EXTRACT(AASNMBLK,1,78)
- +9 SET ^TMP($JOB,D0,784)=$EXTRACT(AASNMBLK,1,78)
- SET ^TMP($JOB,D0,850)=$EXTRACT(AASNMBLK,1,66)
- +10 SET ^TMP($JOB,D0,925)=AASNML_AASNMF_AASNMM_$EXTRACT(AASNMBLK,1,44)
- +11 SET AASDXCIT=$EXTRACT($PIECE(AAS1655("N1"),U),1,25)
- +12 SET AASDXCIT=AASDXCIT_$EXTRACT(AASNMBLK,1,25-$LENGTH(AASDXCIT))
- +13 SET ^TMP($JOB,D0,1000)=$EXTRACT(AASNMBLK,1,32)_AASFSSN_AASDXCIT_$EXTRACT(AASNMBLK,1,10)