SROACOM1 ;BIR/MAM - COMPLETE ASSESSMENT ;05/05/10
;;3.0;Surgery;**166,174,177**;24 Jun 93;Build 89
I '$D(SRTN) Q
S (SRSFLG,SRSOUT,SROVER)=0,SRA=$G(^SRF(SRTN,"RA")),Y=$P(SRA,"^") I Y'="I" W !!,"This assessment has a "_$S(Y="C":"'COMPLETE'",1:"'TRANSMITTED'")_" status.",!!,"No action taken." G END
I $P(SRA,"^",2)="C" D CHK^SROAUTLC
S SRFLD="" I $O(SRX(SRFLD))'="" D LIST
I $P(SRA,"^",2)="C" D CHCK G:SRSOUT END
YEP I '$P($G(^SRO(136,SRTN,10)),"^")!('$P($G(^SRO(136,SRTN,0)),"^",2))!('$P($G(^SRO(136,SRTN,0)),"^",3)) W !!,?6,"The coding for Procedure and Diagnosis is not complete."
W ! S SRFLD="" K DIR S DIR("A")="Are you sure you want to complete this assessment ? ",DIR("B")=$S($O(SRX(SRFLD)):"NO",1:"YES"),DIR(0)="YA"
S DIR("?",1)="Enter YES to complete this assessment, or enter NO to leave the status",DIR("?")="unchanged." D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 G END
I 'Y W !!,"No action taken." G END
I $$LOCK^SROUTL(SRTN) D COMPLT Q
E W !!,"No action taken." G END
Q
COMPLT W !!,"Updating the current status to 'COMPLETE'..." K DR,DIE S DA=SRTN,DIE=130,DR="235///C;272.1////"_DUZ D ^DIE K STATUS
I $P(SRA,"^",5)="" K DR,DIE S DA=SRTN,DIE=130,DR="272///"_DT D ^DIE K STATUS
I $P(SRA,"^",2)="C" K DA,DIE,DIK,DR S DIK="^SRF(",DIK(1)=".232^AQ",DA=SRTN D EN1^DIK K DA,DIK
D UNLOCK^SROUTL(SRTN)
PRINT W !!,"Do you want to print the completed assessment ? YES// " R SRYN:DTIME I '$T!(SRYN["^") S SRSOUT=1 Q
S SRYN=$E(SRYN) S:SRYN="" SRYN="Y" I "Nn"[SRYN S SRSOUT=1 Q
I "Yy"'[SRYN W !!,"Enter <RET> to print the completed assessment, or 'NO' to return to the menu." G PRINT
W ! K %ZIS,IO("Q"),POP S %ZIS("A")="Print the Completed Assessment on which Device: ",%ZIS="Q" D ^%ZIS I POP S SRSOUT=1 Q
I $D(IO("Q")) K IO("Q") S ZTDESC="Completed Surgery Risk Assessment",(ZTSAVE("SRSITE*"),ZTSAVE("SRTN"))="",ZTRTN="EN^SROACOM1" D ^%ZTLOAD S SRSOUT=1 G END
D EN,END
Q
EN U IO S SRABATCH=1 D ^SROAPAS Q
END I 'SRSOUT,$E(IOST)'="P" D RET
W @IOF I $E(IOST)="P" D ^%ZISC W @IOF
D ^SRSKILL K SRMD,SRMD1,SRMDD,SRSFLG
Q
LIST W @IOF,!,"This assessment is missing the following items:",! S SRZ="",SRCNT=1
F S SRZ=$O(SRX(SRZ)) Q:SRZ="" D:$Y+5>IOSL RET Q:SRSOUT W !,?5,$J(SRCNT,2)_". "_$P($P(SRX(SRZ),":"),"^") S SRCNT=SRCNT+1
S SRSOUT=0 W ! K DIR S DIR(0)="Y",DIR("A")="Do you want to enter the missing items at this time",DIR("B")="NO" D ^DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q
Q:'Y I $$LOCK^SROUTL(SRTN) D PRT,UNLOCK^SROUTL(SRTN)
Q
PRT S SRSOUT=0,(SRMD,SRMDD,SRMD1)="",SRCNT=0 F S SRMDD=$O(SRX(SRMDD)) Q:SRMDD="" S SRMD=$P($G(SRX(SRMDD)),":",2),SRMD1=$P($G(SRX(SRMDD)),"^",2) D Q:$G(SRSFLG)
.I SRMD=485 W @IOF,! D PRIOR^SROACL2 K DR,DIE S DA=SRTN,DR="485///"_$S(X="@":"@",1:$P(Y,"^")),DIE=130 D ^DIE K DR S:$D(Y) SRSFLG=1 Q
.K DR,DIE S DA=SRTN,DIE=130,DR=$S($G(SRMD1):SRMD1,1:SRMD)_"T" D ^DIE K DR I $D(Y) S SRSFLG=1
S:'$G(SRSOUT) SRSOUT=0
Q
CHCK ; cardiac checks added by SR*3*93
N SRADM,SRDIS,SRISCH,SRCPB,SRRET S SRRET=0,X=$G(^SRF(SRTN,208)),SRADM=$P(X,"^",14),SRDIS=$P(X,"^",15),X=$G(^SRF(SRTN,206)),SRISCH=$P(X,"^",36),SRCPB=$P(X,"^",37)
I SRADM,SRDIS,SRADM'<SRDIS W !!," *** NOTE: Discharge Date precedes Admission Date!! Please check. ***" D
. S SRRET=1 S:$P($G(SRZZ(418)),U,2)'="" SRX($P(SRZZ(418),"^",2))="" S SRZZ(418)=""
I SRISCH,SRCPB,SRISCH>SRCPB W !!," *** NOTE: Ischemic Time is greater than CPB Time!! Please check. ***",! D
. S SRRET=1 S:$P($G(SRZZ(450)),U,2)'="" SRX($P(SRZZ(450),"^",2))="" S SRZZ(450)=""
I SRRET W ! K DIR S DIR(0)="E" D ^DIR K DIR S:$D(DTOUT)!$D(DUOUT) SRSOUT=1 W !
Q
RET W !! K DIR S DIR(0)="E" D ^DIR K DIR W @IOF I $D(DTOUT)!$D(DUOUT) S SRSOUT=1
Q
PAGE I $E(IOST)'="P" D RET Q
W @IOF,!!!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSROACOM1 3738 printed Apr 09, 2024@21:42:55 Page 2
SROACOM1 ;BIR/MAM - COMPLETE ASSESSMENT ;05/05/10
+1 ;;3.0;Surgery;**166,174,177**;24 Jun 93;Build 89
+2 IF '$DATA(SRTN)
QUIT
+3 SET (SRSFLG,SRSOUT,SROVER)=0
SET SRA=$GET(^SRF(SRTN,"RA"))
SET Y=$PIECE(SRA,"^")
IF Y'="I"
WRITE !!,"This assessment has a "_$SELECT(Y="C":"'COMPLETE'",1:"'TRANSMITTED'")_" status.",!!,"No action taken."
GOTO END
+4 IF $PIECE(SRA,"^",2)="C"
DO CHK^SROAUTLC
+5 SET SRFLD=""
IF $ORDER(SRX(SRFLD))'=""
DO LIST
+6 IF $PIECE(SRA,"^",2)="C"
DO CHCK
if SRSOUT
GOTO END
YEP IF '$PIECE($GET(^SRO(136,SRTN,10)),"^")!('$PIECE($GET(^SRO(136,SRTN,0)),"^",2))!('$PIECE($GET(^SRO(136,SRTN,0)),"^",3))
WRITE !!,?6,"The coding for Procedure and Diagnosis is not complete."
+1 WRITE !
SET SRFLD=""
KILL DIR
SET DIR("A")="Are you sure you want to complete this assessment ? "
SET DIR("B")=$SELECT($ORDER(SRX(SRFLD)):"NO",1:"YES")
SET DIR(0)="YA"
+2 SET DIR("?",1)="Enter YES to complete this assessment, or enter NO to leave the status"
SET DIR("?")="unchanged."
DO ^DIR
KILL DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
SET SRSOUT=1
GOTO END
+3 IF 'Y
WRITE !!,"No action taken."
GOTO END
+4 IF $$LOCK^SROUTL(SRTN)
DO COMPLT
QUIT
+5 IF '$TEST
WRITE !!,"No action taken."
GOTO END
+6 QUIT
COMPLT WRITE !!,"Updating the current status to 'COMPLETE'..."
KILL DR,DIE
SET DA=SRTN
SET DIE=130
SET DR="235///C;272.1////"_DUZ
DO ^DIE
KILL STATUS
+1 IF $PIECE(SRA,"^",5)=""
KILL DR,DIE
SET DA=SRTN
SET DIE=130
SET DR="272///"_DT
DO ^DIE
KILL STATUS
+2 IF $PIECE(SRA,"^",2)="C"
KILL DA,DIE,DIK,DR
SET DIK="^SRF("
SET DIK(1)=".232^AQ"
SET DA=SRTN
DO EN1^DIK
KILL DA,DIK
+3 DO UNLOCK^SROUTL(SRTN)
PRINT WRITE !!,"Do you want to print the completed assessment ? YES// "
READ SRYN:DTIME
IF '$TEST!(SRYN["^")
SET SRSOUT=1
QUIT
+1 SET SRYN=$EXTRACT(SRYN)
if SRYN=""
SET SRYN="Y"
IF "Nn"[SRYN
SET SRSOUT=1
QUIT
+2 IF "Yy"'[SRYN
WRITE !!,"Enter <RET> to print the completed assessment, or 'NO' to return to the menu."
GOTO PRINT
+3 WRITE !
KILL %ZIS,IO("Q"),POP
SET %ZIS("A")="Print the Completed Assessment on which Device: "
SET %ZIS="Q"
DO ^%ZIS
IF POP
SET SRSOUT=1
QUIT
+4 IF $DATA(IO("Q"))
KILL IO("Q")
SET ZTDESC="Completed Surgery Risk Assessment"
SET (ZTSAVE("SRSITE*"),ZTSAVE("SRTN"))=""
SET ZTRTN="EN^SROACOM1"
DO ^%ZTLOAD
SET SRSOUT=1
GOTO END
+5 DO EN
DO END
+6 QUIT
EN USE IO
SET SRABATCH=1
DO ^SROAPAS
QUIT
END IF 'SRSOUT
IF $EXTRACT(IOST)'="P"
DO RET
+1 WRITE @IOF
IF $EXTRACT(IOST)="P"
DO ^%ZISC
WRITE @IOF
+2 DO ^SRSKILL
KILL SRMD,SRMD1,SRMDD,SRSFLG
+3 QUIT
LIST WRITE @IOF,!,"This assessment is missing the following items:",!
SET SRZ=""
SET SRCNT=1
+1 FOR
SET SRZ=$ORDER(SRX(SRZ))
if SRZ=""
QUIT
if $Y+5>IOSL
DO RET
if SRSOUT
QUIT
WRITE !,?5,$JUSTIFY(SRCNT,2)_". "_$PIECE($PIECE(SRX(SRZ),":"),"^")
SET SRCNT=SRCNT+1
+2 SET SRSOUT=0
WRITE !
KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Do you want to enter the missing items at this time"
SET DIR("B")="NO"
DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
SET SRSOUT=1
QUIT
+3 if 'Y
QUIT
IF $$LOCK^SROUTL(SRTN)
DO PRT
DO UNLOCK^SROUTL(SRTN)
+4 QUIT
PRT SET SRSOUT=0
SET (SRMD,SRMDD,SRMD1)=""
SET SRCNT=0
FOR
SET SRMDD=$ORDER(SRX(SRMDD))
if SRMDD=""
QUIT
SET SRMD=$PIECE($GET(SRX(SRMDD)),":",2)
SET SRMD1=$PIECE($GET(SRX(SRMDD)),"^",2)
Begin DoDot:1
+1 IF SRMD=485
WRITE @IOF,!
DO PRIOR^SROACL2
KILL DR,DIE
SET DA=SRTN
SET DR="485///"_$SELECT(X="@":"@",1:$PIECE(Y,"^"))
SET DIE=130
DO ^DIE
KILL DR
if $DATA(Y)
SET SRSFLG=1
QUIT
+2 KILL DR,DIE
SET DA=SRTN
SET DIE=130
SET DR=$SELECT($GET(SRMD1):SRMD1,1:SRMD)_"T"
DO ^DIE
KILL DR
IF $DATA(Y)
SET SRSFLG=1
End DoDot:1
if $GET(SRSFLG)
QUIT
+3 if '$GET(SRSOUT)
SET SRSOUT=0
+4 QUIT
CHCK ; cardiac checks added by SR*3*93
+1 NEW SRADM,SRDIS,SRISCH,SRCPB,SRRET
SET SRRET=0
SET X=$GET(^SRF(SRTN,208))
SET SRADM=$PIECE(X,"^",14)
SET SRDIS=$PIECE(X,"^",15)
SET X=$GET(^SRF(SRTN,206))
SET SRISCH=$PIECE(X,"^",36)
SET SRCPB=$PIECE(X,"^",37)
+2 IF SRADM
IF SRDIS
IF SRADM'<SRDIS
WRITE !!," *** NOTE: Discharge Date precedes Admission Date!! Please check. ***"
Begin DoDot:1
+3 SET SRRET=1
if $PIECE($GET(SRZZ(418)),U,2)'=""
SET SRX($PIECE(SRZZ(418),"^",2))=""
SET SRZZ(418)=""
End DoDot:1
+4 IF SRISCH
IF SRCPB
IF SRISCH>SRCPB
WRITE !!," *** NOTE: Ischemic Time is greater than CPB Time!! Please check. ***",!
Begin DoDot:1
+5 SET SRRET=1
if $PIECE($GET(SRZZ(450)),U,2)'=""
SET SRX($PIECE(SRZZ(450),"^",2))=""
SET SRZZ(450)=""
End DoDot:1
+6 IF SRRET
WRITE !
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
if $DATA(DTOUT)!$DATA(DUOUT)
SET SRSOUT=1
WRITE !
+7 QUIT
RET WRITE !!
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
WRITE @IOF
IF $DATA(DTOUT)!$DATA(DUOUT)
SET SRSOUT=1
+1 QUIT
PAGE IF $EXTRACT(IOST)'="P"
DO RET
QUIT
+1 WRITE @IOF,!!!
+2 QUIT
