SRONASS.m

SRONASS ;B'HAM ISC/MAM - NO ASSESSMENT REASON ; [ 04/13/04  10:30 PM ]

 ;;3.0; Surgery ;**38,47,83,107,121,100,125**;24 Jun 93

 K SRTN S SRSOUT=0 N SRSEL D ^SROPSEL I '$D(DFN) S SRSOUT=1 G END

 D @$S(SRSEL=2:"^SROPSN",1:"STL^SROPS") I '$D(SRTN) S SRSOUT=1 G END

 S X=$P($G(^SRF(SRTN,"RA")),"^",6) I X="Y" D ASS I 'OK G END

 N SRLCK S SRLCK=$$LOCK^SROUTL(SRTN) I 'SRLCK G END

 D SRA^SROES

 W ! K DIR S X=$P($G(^SRF(SRTN,"RA")),"^",7) I X'="" D SET S DIR("B")=X

 S DIR(0)="130,102",DIR("A")="Reason an Assessment was not Created" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT)!(Y=""&(X'="@")) S SRSOUT=1 G END

 I X="@" D DELETE G END1

 I X'="" K DR,DA,DIE S DIE=130,DR="102///"_X_";323////N;284////N;Q;235////C",DA=SRTN D ^DIE K DR,DIE,DA

 D ^SROAEX S SROERR=SRTN D ^SROERR0

END1 K DA,DIK S DIK="^SRF(",DIK(1)=".232^AQ",DA=SRTN D EN1^DIK

 D EXIT^SROES

END I $G(SRLCK) D UNLOCK^SROUTL(SRTN)

 K SRTN D ^SRSKILL W @IOF

 Q

LOOP ; break procedure

 S SROPS(M)="" F LOOP=1:1 S MM=$P(SROPER," "),MMM=$P(SROPER," ",2,200) Q:MMM=""  Q:$L(SROPS(M))+$L(MM)'<60  S SROPS(M)=SROPS(M)_MM_" ",SROPER=MMM

 Q

OTHER ; other operations

 S SRLONG=1 I $L(SROPER)+$L($P(^SRF(SRTN,13,SROTHER,0),"^"))>235 S SRLONG=0,SROTHER=999,SROPERS=" ..."

 I SRLONG S SROPERS=$P(^SRF(SRTN,13,SROTHER,0),"^")

 S SROPER=SROPER_$S(SROPERS=" ...":SROPERS,1:", "_SROPERS)

 Q

SET ; expand reason for no assessment code

 S Y=X,C=$P(^DD(130,102,0),"^",2) D Y^DIQ S X=Y

 Q

ASS ; assessment already exists

 S OK=0 W !!,"According to your records, an assessment should be created for this surgical",!,"case."

ASK W !!,"Do you want to update this information and not create a surgery risk ",!,"assessment for this case ?  NO// " R SRYN:DTIME I '$T!(SRYN["^") S OK="" Q

 S SRYN=$E(SRYN) S:SRYN="" SRYN="N" I "YyNn"'[SRYN S SRYN="?"

 I SRYN="?" W !!,"If this case will not be used for the risk assessment study, Enter 'YES' to ",!,"change the status.  You will then be prompted for the reason that no assessment",!,"was done.  Enter 'NO' to leave this case unchanged."

 I SRYN="?" G ASK

 I "Yy"[SRYN S OK=1

 I "Nn"[SRYN W !!,"No action taken.",!!,"Press RETURN to continue  " R X:DTIME

 Q

DELETE ; delete no assessment reason

 W !!,"If you delete the reason why no assessment was created for this case, the",!,"computer will automatically update your records to make this a non-assessed",!,"case."

 W !!,"Are you sure that you want to delete the reason ?  NO// " R SRYN:DTIME I '$T!(SRYN["^") S SRSOUT=1 Q

 S SRYN=$E(SRYN) S:SRYN="" SRYN="N" I "YyNn"'[SRYN S SRYN="?"

 I SRYN="?" W !!,"By entering an '@', you have told the computer that you want to remove the ",!,"reason why no assessment was created for this case.  If this reason should be",!,"deleted, enter 'YES'." G DELETE

 I "Nn"[SRYN S SRSOUT=1 W !!,"No action taken.",!!,"Press RETURN to continue  " R X:DTIME Q

 W !!,"Updating to non-assessed status..." D DRDEL W !!,"Press RETURN to continue  " R X:DTIME

 Q

DRDEL K DR,DIE,DA S DIE=130,DA=SRTN,DR="235///@;284///@;393///@;260///@;272///@;323///@;102///@;260.1///@" D ^DIE K DR,DIE,DA

 Q

SRONASS   ;B'HAM ISC/MAM - NO ASSESSMENT REASON ; [ 04/13/04  10:30 PM ]

 +1       ;;3.0; Surgery ;**38,47,83,107,121,100,125**;24 Jun 93

 +2        KILL SRTN

           SET SRSOUT=0

           NEW SRSEL

           DO ^SROPSEL

           IF '$DATA(DFN)

               SET SRSOUT=1

               GOTO END

 +3        DO @$SELECT(SRSEL=2:"^SROPSN",1:"STL^SROPS")

           IF '$DATA(SRTN)

               SET SRSOUT=1

               GOTO END

 +4        SET X=$PIECE($GET(^SRF(SRTN,"RA")),"^",6)

           IF X="Y"

               DO ASS

               IF 'OK

                   GOTO END

 +5        NEW SRLCK

           SET SRLCK=$$LOCK^SROUTL(SRTN)

           IF 'SRLCK

               GOTO END

 +6        DO SRA^SROES

 +7        WRITE !

           KILL DIR

           SET X=$PIECE($GET(^SRF(SRTN,"RA")),"^",7)

           IF X'=""

               DO SET

               SET DIR("B")=X

 +8        SET DIR(0)="130,102"

           SET DIR("A")="Reason an Assessment was not Created"

           DO ^DIR

           KILL DIR

           IF $DATA(DTOUT)!$DATA(DUOUT)!(Y=""&(X'="@"))

               SET SRSOUT=1

               GOTO END

 +9        IF X="@"

               DO DELETE

               GOTO END1

 +10       IF X'=""

               KILL DR,DA,DIE

               SET DIE=130

               SET DR="102///"_X_";323////N;284////N;Q;235////C"

               SET DA=SRTN

               DO ^DIE

               KILL DR,DIE,DA

 +11       DO ^SROAEX

           SET SROERR=SRTN

           DO ^SROERR0

END1       KILL DA,DIK

           SET DIK="^SRF("

           SET DIK(1)=".232^AQ"

           SET DA=SRTN

           DO EN1^DIK

 +1        DO EXIT^SROES

END        IF $GET(SRLCK)

               DO UNLOCK^SROUTL(SRTN)

 +1        KILL SRTN

           DO ^SRSKILL

           WRITE @IOF

 +2        QUIT 

LOOP      ; break procedure

 +1        SET SROPS(M)=""

           FOR LOOP=1:1

               SET MM=$PIECE(SROPER," ")

               SET MMM=$PIECE(SROPER," ",2,200)

               IF MMM=""

                   QUIT 

               IF $LENGTH(SROPS(M))+$LENGTH(MM)'<60

                   QUIT 

               SET SROPS(M)=SROPS(M)_MM_" "

               SET SROPER=MMM

 +2        QUIT 

OTHER     ; other operations

 +1        SET SRLONG=1

           IF $LENGTH(SROPER)+$LENGTH($PIECE(^SRF(SRTN,13,SROTHER,0),"^"))>235

               SET SRLONG=0

               SET SROTHER=999

               SET SROPERS=" ..."

 +2        IF SRLONG

               SET SROPERS=$PIECE(^SRF(SRTN,13,SROTHER,0),"^")

 +3        SET SROPER=SROPER_$SELECT(SROPERS=" ...":SROPERS,1:", "_SROPERS)

 +4        QUIT 

SET       ; expand reason for no assessment code

 +1        SET Y=X

           SET C=$PIECE(^DD(130,102,0),"^",2)

           DO Y^DIQ

           SET X=Y

 +2        QUIT 

ASS       ; assessment already exists

 +1        SET OK=0

           WRITE !!,"According to your records, an assessment should be created for this surgical",!,"case."

ASK        WRITE !!,"Do you want to update this information and not create a surgery risk ",!,"assessment for this case ?  NO// "

           READ SRYN:DTIME

           IF '$TEST!(SRYN["^")

               SET OK=""

               QUIT 

 +1        SET SRYN=$EXTRACT(SRYN)

           IF SRYN=""

               SET SRYN="N"

           IF "YyNn"'[SRYN

               SET SRYN="?"

 +2        IF SRYN="?"

               WRITE !!,"If this case will not be used for the risk assessment study, Enter 'YES' to ",!,"change the status.  You will then be prompted for the reason that no assessment",!,"was done.  Enter 'NO' to leave this case unchanged."

 +3        IF SRYN="?"

               GOTO ASK

 +4        IF "Yy"[SRYN

               SET OK=1

 +5        IF "Nn"[SRYN

               WRITE !!,"No action taken.",!!,"Press RETURN to continue  "

               READ X:DTIME

 +6        QUIT 

DELETE    ; delete no assessment reason

 +1        WRITE !!,"If you delete the reason why no assessment was created for this case, the",!,"computer will automatically update your records to make this a non-assessed",!,"case."

 +2        WRITE !!,"Are you sure that you want to delete the reason ?  NO// "

           READ SRYN:DTIME

           IF '$TEST!(SRYN["^")

               SET SRSOUT=1

               QUIT 

 +3        SET SRYN=$EXTRACT(SRYN)

           IF SRYN=""

               SET SRYN="N"

           IF "YyNn"'[SRYN

               SET SRYN="?"

 +4        IF SRYN="?"

               WRITE !!,"By entering an '@', you have told the computer that you want to remove the ",!,"reason why no assessment was created for this case.  If this reason should be",!,"deleted, enter 'YES'."

               GOTO DELETE

 +5        IF "Nn"[SRYN

               SET SRSOUT=1

               WRITE !!,"No action taken.",!!,"Press RETURN to continue  "

               READ X:DTIME

               QUIT 

 +6        WRITE !!,"Updating to non-assessed status..."

           DO DRDEL

           WRITE !!,"Press RETURN to continue  "

           READ X:DTIME

 +7        QUIT 

DRDEL      KILL DR,DIE,DA

           SET DIE=130

           SET DA=SRTN

           SET DR="235///@;284///@;393///@;260///@;272///@;323///@;102///@;260.1///@"

           DO ^DIE

           KILL DR,DIE,DA

 +1        QUIT