SRTPRACE ;BIR/SJA - RACE INFORMATION ;03/27/08
;;3.0; Surgery ;**167**;24 Jun 93;Build 27
N RAC,I,SRY,CNT,SRPAGE,SRYN S $P(SRLINE,"-",80)=""
S SRSOUT=0 I '$D(SRTPP) W @IOF,!!,"A transplant assessment must be selected prior to using this option.",!!,"Press RETURN to continue " R X:DTIME S SRSOUT=1 G END
START S SRPAGE="RACE INFORMATION" D HDR
K SRORAC S (RAC,CNT)=0 F S RAC=$O(^SRT(SRTPP,44,RAC)) Q:'RAC!($D(SRORAC)) Q:SRSOUT S CNT=CNT+1 D LIST I CNT=13 W !!,SRLINE D SEL
I SRSOUT Q
I $D(SRORAC) D EDIT G START
I CNT W !!,SRLINE
I CNT=0 D ASK G:'SRSOUT START S SRSOUT=0 Q
OPT W !!,"Enter "_$S(CNT=1:1,1:"(1-"_CNT_")")_" to edit an existing race, or 'NEW' to enter another race code: " R X:DTIME I '$T!("^"[X) Q
I "Nn"[$E(X) D NEW G START
I '$D(SRACE(X)) W !!,"Select the number corresponding to the race you want to edit, or 'NEW' to",!,"enter an additional race information." G OPT
S SRORAC=$P(SRACE(X),"^",3) D EDIT G START
Q
END I 'SRSOUT W !!,"Press RETURN to continue " R X:DTIME
D ^SRSKILL W @IOF
Q
LIST ; list existing race
K SRY S DIC="^SRT(",DR=44,DA=SRTPP,DR(139.544)=".01",DA(139.544)=RAC,DIQ="SRY",DIQ(0)="E" D EN^DIQ1
S SRACE(CNT)=$G(^SRT(SRTPP,44,RAC,0))_"^"_$G(SRY(139.544,RAC,.01,"E"))_"^"_RAC
W !,$S(CNT<10:" ",1:"")_CNT_". "_$P(SRACE(CNT),"^",2)
Q
SEL ; select race
W !!,"Select (1-"_CNT_") to edit an existing race, or RETURN to continue: " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
I X="" S CNT=0 K SRACE D HDR Q
I '$D(SRACE(X)) W !!,"Enter the number corresponding to the race you want to edit, or RETURN",!,"to continue listing." G SEL
S SRORAC=$P(SRACE(X),"^",3)
Q
HDR ; print screen header
I '$D(SRHDR) D SRHDR^SRTPUTL
W @IOF,!,SRHDR W:$G(SRPAGE)'="" ?(79-$L(SRPAGE)),SRPAGE
S I=0 F S I=$O(SRHDR(I)) Q:'I W !,SRHDR(I) I I=1,$L($G(SRHPG)) W ?(79-$L(SRHPG)),SRHPG
K SRHPG,SRPAGE W ! F I=1:1:80 W "-"
W !
Q
EDIT ; edit one race
D HDR W ! S DA=SRORAC,DIE="^SRT("_SRTPP_",44,",DA(1)=SRTPP,DR=".01T" D ^DIE K DR,DIE
Q
ASK W !!,"There are no race data entered for this donor. Do you want to add",!,"a new race ? YES// " R SRYN:DTIME I '$T!(SRYN["^") S SRYN="N"
S:SRYN="" SRYN="Y"
S SRYN=$E(SRYN) I "YyNn"'[SRYN W !!,"Enter 'YES' to add another race, or 'NO' to return to the",!,"previous screen." G ASK
I "Nn"[SRYN S SRSOUT=1 Q
NEW D HDR W ! K DIR,DA S DIR(0)="139.544,.01",DIR("A")="Donor Race" D ^DIR I Y=""!$D(DTOUT)!$D(DUOUT) Q
I $D(^SRT(SRTPP,44,"B",Y)) W $C(7)," ??" Q
I '$D(^SRT(SRTPP,44,0)) S ^SRT(SRTPP,44,0)="^139.544SA^^"
K DA,DIC,DD,DO,DINUM S DA(1)=SRTPP,X=Y,DIC="^SRT("_SRTPP_",44,",DIC(0)="L" D FILE^DICN K DA,DIC,DD,DO,DINUM
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSRTPRACE 2650 printed Nov 22, 2024@17:58:38 Page 2
SRTPRACE ;BIR/SJA - RACE INFORMATION ;03/27/08
+1 ;;3.0; Surgery ;**167**;24 Jun 93;Build 27
+2 NEW RAC,I,SRY,CNT,SRPAGE,SRYN
SET $PIECE(SRLINE,"-",80)=""
+3 SET SRSOUT=0
IF '$DATA(SRTPP)
WRITE @IOF,!!,"A transplant assessment must be selected prior to using this option.",!!,"Press RETURN to continue "
READ X:DTIME
SET SRSOUT=1
GOTO END
START SET SRPAGE="RACE INFORMATION"
DO HDR
+1 KILL SRORAC
SET (RAC,CNT)=0
FOR
SET RAC=$ORDER(^SRT(SRTPP,44,RAC))
if 'RAC!($DATA(SRORAC))
QUIT
if SRSOUT
QUIT
SET CNT=CNT+1
DO LIST
IF CNT=13
WRITE !!,SRLINE
DO SEL
+2 IF SRSOUT
QUIT
+3 IF $DATA(SRORAC)
DO EDIT
GOTO START
+4 IF CNT
WRITE !!,SRLINE
+5 IF CNT=0
DO ASK
if 'SRSOUT
GOTO START
SET SRSOUT=0
QUIT
OPT WRITE !!,"Enter "_$SELECT(CNT=1:1,1:"(1-"_CNT_")")_" to edit an existing race, or 'NEW' to enter another race code: "
READ X:DTIME
IF '$TEST!("^"[X)
QUIT
+1 IF "Nn"[$EXTRACT(X)
DO NEW
GOTO START
+2 IF '$DATA(SRACE(X))
WRITE !!,"Select the number corresponding to the race you want to edit, or 'NEW' to",!,"enter an additional race information."
GOTO OPT
+3 SET SRORAC=$PIECE(SRACE(X),"^",3)
DO EDIT
GOTO START
+4 QUIT
END IF 'SRSOUT
WRITE !!,"Press RETURN to continue "
READ X:DTIME
+1 DO ^SRSKILL
WRITE @IOF
+2 QUIT
LIST ; list existing race
+1 KILL SRY
SET DIC="^SRT("
SET DR=44
SET DA=SRTPP
SET DR(139.544)=".01"
SET DA(139.544)=RAC
SET DIQ="SRY"
SET DIQ(0)="E"
DO EN^DIQ1
+2 SET SRACE(CNT)=$GET(^SRT(SRTPP,44,RAC,0))_"^"_$GET(SRY(139.544,RAC,.01,"E"))_"^"_RAC
+3 WRITE !,$SELECT(CNT<10:" ",1:"")_CNT_". "_$PIECE(SRACE(CNT),"^",2)
+4 QUIT
SEL ; select race
+1 WRITE !!,"Select (1-"_CNT_") to edit an existing race, or RETURN to continue: "
READ X:DTIME
IF '$TEST!(X["^")
SET SRSOUT=1
QUIT
+2 IF X=""
SET CNT=0
KILL SRACE
DO HDR
QUIT
+3 IF '$DATA(SRACE(X))
WRITE !!,"Enter the number corresponding to the race you want to edit, or RETURN",!,"to continue listing."
GOTO SEL
+4 SET SRORAC=$PIECE(SRACE(X),"^",3)
+5 QUIT
HDR ; print screen header
+1 IF '$DATA(SRHDR)
DO SRHDR^SRTPUTL
+2 WRITE @IOF,!,SRHDR
if $GET(SRPAGE)'=""
WRITE ?(79-$LENGTH(SRPAGE)),SRPAGE
+3 SET I=0
FOR
SET I=$ORDER(SRHDR(I))
if 'I
QUIT
WRITE !,SRHDR(I)
IF I=1
IF $LENGTH($GET(SRHPG))
WRITE ?(79-$LENGTH(SRHPG)),SRHPG
+4 KILL SRHPG,SRPAGE
WRITE !
FOR I=1:1:80
WRITE "-"
+5 WRITE !
+6 QUIT
EDIT ; edit one race
+1 DO HDR
WRITE !
SET DA=SRORAC
SET DIE="^SRT("_SRTPP_",44,"
SET DA(1)=SRTPP
SET DR=".01T"
DO ^DIE
KILL DR,DIE
+2 QUIT
ASK WRITE !!,"There are no race data entered for this donor. Do you want to add",!,"a new race ? YES// "
READ SRYN:DTIME
IF '$TEST!(SRYN["^")
SET SRYN="N"
+1 if SRYN=""
SET SRYN="Y"
+2 SET SRYN=$EXTRACT(SRYN)
IF "YyNn"'[SRYN
WRITE !!,"Enter 'YES' to add another race, or 'NO' to return to the",!,"previous screen."
GOTO ASK
+3 IF "Nn"[SRYN
SET SRSOUT=1
QUIT
NEW DO HDR
WRITE !
KILL DIR,DA
SET DIR(0)="139.544,.01"
SET DIR("A")="Donor Race"
DO ^DIR
IF Y=""!$DATA(DTOUT)!$DATA(DUOUT)
QUIT
+1 IF $DATA(^SRT(SRTPP,44,"B",Y))
WRITE $CHAR(7)," ??"
QUIT
+2 IF '$DATA(^SRT(SRTPP,44,0))
SET ^SRT(SRTPP,44,0)="^139.544SA^^"
+3 KILL DA,DIC,DD,DO,DINUM
SET DA(1)=SRTPP
SET X=Y
SET DIC="^SRT("_SRTPP_",44,"
SET DIC(0)="L"
DO FILE^DICN
KILL DA,DIC,DD,DO,DINUM
+4 QUIT
