- SROAMAN ;BIR/ADM-Managerial Site ID and Assessment Data Input; [ 04/26/97 2:55 PM ]
- ;;3.0; Surgery ;**38,39,55,61,67**;24 Jun 93
- MAN() ; determine if site is a risk assessment managerial site
- N MAN,SITE,Y S MAN=0,SITE=+$P($$SITE^SROVAR,"^",3)
- S Y="436,442,503,505,517,519,556,557,564,568,569,574,579,585,591,595,609,612,613,617,619,622,623,647,655,659,668,677,680,686,687"
- S:Y[SITE MAN=1 K SITE,Y
- Q MAN
- PRE S (SRFLG,SRCC)=1,SRR=0,SRPROMPT="Preoperative Information" D HDR^SROAUTL,OUT1^SROAUTL0,SEL Q:SRSOUT G:SRR PRE
- I $D(SRCC) D CONCC
- Q
- LAB S SRCC=1,SRR=0,SRPROMPT="Preoperative Laboratory Information" D HDR^SROAUTL,LAB^SROAUTL0,SEL Q:SRSOUT G:SRR LAB
- I $D(SRCC) D CONCC
- Q
- SEL W !!,"Select "_SRPROMPT_" to edit: " R X:DTIME I '$T!(X["^") D:$D(SRCC) CONCC S SRSOUT=1 Q
- Q:X="" S:X="a" X="A" I '$D(SRFLG),'$D(SRX(X)),(X'?1.2N1":"1.2N),X'="A" D HELP S SRR=1 Q
- I $D(SRFLG),'$D(SRX(X)),(X'?1.2N1":"1.2N),X'="A",X'="N",X'="NO",X'="@" D HELP S SRR=1 Q
- I X?1.2N1":"1.2N S Y=$P(X,":"),Z=$P(X,":",2) I Y<1!(Z>SRX)!(Y>Z) D HELP S SRR=1 Q
- I $D(SRFLG),(X="N"!(X="NO")) D NO S SRR=1 Q
- I $D(SRFLG),X="@" D DEL S SRR=1 Q
- S MM=$E(X) I $D(SRCC)!('$D(SRCC)&((MM'=4)!(MM'=5))) D HDR^SROAUTL
- I X="A" S X="1:"_SRX
- I X?1.2N1":"1.2N D RANGE S SRR=1 Q
- I $D(SRX(X)),+X=X S EMILY=X D ONE S SRR=1
- Q
- OERR S SROERR=SRTN D ^SROERR0
- Q
- HELP W @IOF,!!!!,"Enter the number, number/letter combination, or range of numbers you",!,"want to edit. Examples of proper responses are listed below."
- W !!,"1. Enter 'A' to update all items.",!!,"2. Enter a number (1-"_SRX_") to update an individual item. (For example,",!," enter '1' to update "_$P(SRX(1),"^")_")"
- W !!,"3. Enter a range of numbers (1-"_SRX_") separated by a ':' to enter a range",!," of items. (For example, enter '1:4' to update items 1, 2, 3 and 4.)",!
- I $D(SRFLG) W !,"4. Enter 'N' or 'NO' to enter negative response for all items.",!!,"5. Enter '@' to delete information from all items.",!
- D PRESS
- Q
- RANGE ; range of numbers
- S SHEMP=$P(X,":"),CURLEY=$P(X,":",2) F EMILY=SHEMP:1:CURLEY Q:SRSOUT D ONE
- Q
- ONE ; edit one item
- K DR,DA,DIE S DR=$P(SRX(EMILY),"^",2)_"T",DA=SRTN,DIE=130,SRDT=$P(SRX(EMILY),"^",3) S:SRDT DR=DR_";"_SRDT_"T" D ^DIE K DR,DA I $D(Y) S SRSOUT=1
- Q
- PRESS W ! K DIR S DIR("A")="Press the return key to continue or '^' to exit: ",DIR(0)="FOA" D ^DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1
- Q
- CONCC ; check for concurrent case and update if one exists
- S SRCON=$P($G(^SRF(SRTN,"CON")),"^") Q:'SRCON
- Q:$P($G(^SRF(SRCON,"RA")),"^",2)="C"
- K DA,DIC,DIQ,DR,SRY S DA=SRTN,DR=SRDR,DIC="^SRF(",DIQ="SRY",DIQ(0)="I" D EN^DIQ1
- S SRI="" F S SRI=$O(SRY(130,SRTN,SRI)) Q:'SRI S SRW=SRY(130,SRTN,SRI,"I") S:SRW="" SRW="@" K DA,DIE,DR S DA=SRCON,DIE=130,DR=SRI_"////"_SRW D ^DIE
- Q
- NO ; stuff negative responses for all items
- K DA,DIE,DR S DR="" F SRI=1:1 S SRFLD=$P(SRDR,";",SRI) Q:'SRFLD S DR=DR_SRFLD_"////"_$S(SRFLD=240:1,SRFLD=325:1,SRFLD=413:1,1:"N")_";"
- S DA=SRTN,DIE=130 D ^DIE K DA,DIE,DR
- Q
- DEL ; delete information for all items
- W !,*7 K DIR S DIR("A")=" Are you sure you want to delete all information ",DIR(0)="Y" D ^DIR K DIR I 'Y!$D(DTOUT)!$D(DUOUT) Q
- K DA,DIE,DR S DR="" F SRI=1:1 S SRFLD=$P(SRDR,";",SRI) Q:'SRFLD S DR=DR_SRFLD_"////@;"
- S DA=SRTN,DIE=130 D ^DIE K DA,DIE,DR
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSROAMAN 3329 printed Feb 19, 2025@00:07:33 Page 2
- SROAMAN ;BIR/ADM-Managerial Site ID and Assessment Data Input; [ 04/26/97 2:55 PM ]
- +1 ;;3.0; Surgery ;**38,39,55,61,67**;24 Jun 93
- MAN() ; determine if site is a risk assessment managerial site
- +1 NEW MAN,SITE,Y
- SET MAN=0
- SET SITE=+$PIECE($$SITE^SROVAR,"^",3)
- +2 SET Y="436,442,503,505,517,519,556,557,564,568,569,574,579,585,591,595,609,612,613,617,619,622,623,647,655,659,668,677,680,686,687"
- +3 if Y[SITE
- SET MAN=1
- KILL SITE,Y
- +4 QUIT MAN
- PRE SET (SRFLG,SRCC)=1
- SET SRR=0
- SET SRPROMPT="Preoperative Information"
- DO HDR^SROAUTL
- DO OUT1^SROAUTL0
- DO SEL
- if SRSOUT
- QUIT
- if SRR
- GOTO PRE
- +1 IF $DATA(SRCC)
- DO CONCC
- +2 QUIT
- LAB SET SRCC=1
- SET SRR=0
- SET SRPROMPT="Preoperative Laboratory Information"
- DO HDR^SROAUTL
- DO LAB^SROAUTL0
- DO SEL
- if SRSOUT
- QUIT
- if SRR
- GOTO LAB
- +1 IF $DATA(SRCC)
- DO CONCC
- +2 QUIT
- SEL WRITE !!,"Select "_SRPROMPT_" to edit: "
- READ X:DTIME
- IF '$TEST!(X["^")
- if $DATA(SRCC)
- DO CONCC
- SET SRSOUT=1
- QUIT
- +1 if X=""
- QUIT
- if X="a"
- SET X="A"
- IF '$DATA(SRFLG)
- IF '$DATA(SRX(X))
- IF (X'?1.2N1":"1.2N)
- IF X'="A"
- DO HELP
- SET SRR=1
- QUIT
- +2 IF $DATA(SRFLG)
- IF '$DATA(SRX(X))
- IF (X'?1.2N1":"1.2N)
- IF X'="A"
- IF X'="N"
- IF X'="NO"
- IF X'="@"
- DO HELP
- SET SRR=1
- QUIT
- +3 IF X?1.2N1":"1.2N
- SET Y=$PIECE(X,":")
- SET Z=$PIECE(X,":",2)
- IF Y<1!(Z>SRX)!(Y>Z)
- DO HELP
- SET SRR=1
- QUIT
- +4 IF $DATA(SRFLG)
- IF (X="N"!(X="NO"))
- DO NO
- SET SRR=1
- QUIT
- +5 IF $DATA(SRFLG)
- IF X="@"
- DO DEL
- SET SRR=1
- QUIT
- +6 SET MM=$EXTRACT(X)
- IF $DATA(SRCC)!('$DATA(SRCC)&((MM'=4)!(MM'=5)))
- DO HDR^SROAUTL
- +7 IF X="A"
- SET X="1:"_SRX
- +8 IF X?1.2N1":"1.2N
- DO RANGE
- SET SRR=1
- QUIT
- +9 IF $DATA(SRX(X))
- IF +X=X
- SET EMILY=X
- DO ONE
- SET SRR=1
- +10 QUIT
- OERR SET SROERR=SRTN
- DO ^SROERR0
- +1 QUIT
- HELP WRITE @IOF,!!!!,"Enter the number, number/letter combination, or range of numbers you",!,"want to edit. Examples of proper responses are listed below."
- +1 WRITE !!,"1. Enter 'A' to update all items.",!!,"2. Enter a number (1-"_SRX_") to update an individual item. (For example,",!," enter '1' to update "_$PIECE(SRX(1),"^")_")"
- +2 WRITE !!,"3. Enter a range of numbers (1-"_SRX_") separated by a ':' to enter a range",!," of items. (For example, enter '1:4' to update items 1, 2, 3 and 4.)",!
- +3 IF $DATA(SRFLG)
- WRITE !,"4. Enter 'N' or 'NO' to enter negative response for all items.",!!,"5. Enter '@' to delete information from all items.",!
- +4 DO PRESS
- +5 QUIT
- RANGE ; range of numbers
- +1 SET SHEMP=$PIECE(X,":")
- SET CURLEY=$PIECE(X,":",2)
- FOR EMILY=SHEMP:1:CURLEY
- if SRSOUT
- QUIT
- DO ONE
- +2 QUIT
- ONE ; edit one item
- +1 KILL DR,DA,DIE
- SET DR=$PIECE(SRX(EMILY),"^",2)_"T"
- SET DA=SRTN
- SET DIE=130
- SET SRDT=$PIECE(SRX(EMILY),"^",3)
- if SRDT
- SET DR=DR_";"_SRDT_"T"
- DO ^DIE
- KILL DR,DA
- IF $DATA(Y)
- SET SRSOUT=1
- +2 QUIT
- PRESS WRITE !
- KILL DIR
- SET DIR("A")="Press the return key to continue or '^' to exit: "
- SET DIR(0)="FOA"
- DO ^DIR
- IF $DATA(DTOUT)!$DATA(DUOUT)
- SET SRSOUT=1
- +1 QUIT
- CONCC ; check for concurrent case and update if one exists
- +1 SET SRCON=$PIECE($GET(^SRF(SRTN,"CON")),"^")
- if 'SRCON
- QUIT
- +2 if $PIECE($GET(^SRF(SRCON,"RA")),"^",2)="C"
- QUIT
- +3 KILL DA,DIC,DIQ,DR,SRY
- SET DA=SRTN
- SET DR=SRDR
- SET DIC="^SRF("
- SET DIQ="SRY"
- SET DIQ(0)="I"
- DO EN^DIQ1
- +4 SET SRI=""
- FOR
- SET SRI=$ORDER(SRY(130,SRTN,SRI))
- if 'SRI
- QUIT
- SET SRW=SRY(130,SRTN,SRI,"I")
- if SRW=""
- SET SRW="@"
- KILL DA,DIE,DR
- SET DA=SRCON
- SET DIE=130
- SET DR=SRI_"////"_SRW
- DO ^DIE
- +5 QUIT
- NO ; stuff negative responses for all items
- +1 KILL DA,DIE,DR
- SET DR=""
- FOR SRI=1:1
- SET SRFLD=$PIECE(SRDR,";",SRI)
- if 'SRFLD
- QUIT
- SET DR=DR_SRFLD_"////"_$SELECT(SRFLD=240:1,SRFLD=325:1,SRFLD=413:1,1:"N")_";"
- +2 SET DA=SRTN
- SET DIE=130
- DO ^DIE
- KILL DA,DIE,DR
- +3 QUIT
- DEL ; delete information for all items
- +1 WRITE !,*7
- KILL DIR
- SET DIR("A")=" Are you sure you want to delete all information "
- SET DIR(0)="Y"
- DO ^DIR
- KILL DIR
- IF 'Y!$DATA(DTOUT)!$DATA(DUOUT)
- QUIT
- +2 KILL DA,DIE,DR
- SET DR=""
- FOR SRI=1:1
- SET SRFLD=$PIECE(SRDR,";",SRI)
- if 'SRFLD
- QUIT
- SET DR=DR_SRFLD_"////@;"
- +3 SET DA=SRTN
- SET DIE=130
- DO ^DIE
- KILL DA,DIE,DR
- +4 QUIT