SROESARA ;BIR/ADM - ANESTHESIA REPORT E-SIG UTILITY ; [ 02/21/01 9:08 AM ]
;;3.0; Surgery ;**100**;24 Jun 93
;
;** NOTICE: This routine is part of an implementation of a nationally
;** controlled procedure. Local modifications to this routine
;** are prohibited.
;
MULT ; process multiples
S X=$P(SRFLD,"^",2),Y=$P(SRFLD,"^",3) I $P(X,";")=0 S:SRS=1 ^TMP("SRASAVE",$J,SRTN,$P(SRFLD,"^"),0)=$G(^SRF(SRTN,$P(Y,","),0)) Q
S SRCAT=$P(SRFLD,"^"),SRSUB=$P(SRFLD,"^",2),SRFF=$P(SRSUB,"-",3)
S SRNP=$P(SRFLD,"^",3),SRN=$P(SRNP,";"),SRP=$P(SRNP,";",2)
K SRL F I=1:1 S Y=$P(SRN,",",I) Q:Y="" S SRL(I)=Y,SRL=I
S SRW=$S($P(SRFF,";",2)["W":1,1:0)
S SRE=0 F S SRE=$O(^SRF(SRTN,SRL(1),SRE)) Q:'SRE D
.I SRL=2 D
..I SRS=1 D
...I $P(SRFF,",",2)=.01 S ^TMP("SRASAVE",$J,SRTN,SRCAT,0)=$G(^SRF(SRTN,SRL(1),0))
...S ^TMP("SRASAVE",$J,SRTN,SRCAT,SRE,0,SRSUB)=$P($G(^SRF(SRTN,SRL(1),SRE,SRL(2))),"^",SRP)
..I $P(SRSUB,"-")'["X" S ^TMP("SRARAD"_SRS,$J,SRTN,SRCAT,SRE,0,SRSUB)=$P($G(^SRF(SRTN,SRL(1),SRE,SRL(2))),"^",SRP)
.I SRL=3 S SRE1=0 F S SRE1=$O(^SRF(SRTN,SRL(1),SRE,SRL(2),SRE1)) Q:'SRE1 D
..I SRW D Q
...I SRS=1 D
....S ^TMP("SRASAVE",$J,SRTN,SRCAT,SRE,0,SRSUB,0)=$G(^SRF(SRTN,SRL(1),SRE,SRL(2),0))
....S ^TMP("SRASAVE",$J,SRTN,SRCAT,SRE,0,SRSUB,SRE1)=$P($G(^SRF(SRTN,SRL(1),SRE,SRL(2),SRE1,SRL(3))),"^",SRP)
...I $P(SRSUB,"-")'["X" S ^TMP("SRARAD"_SRS,$J,SRTN,SRCAT,SRE,0,SRSUB,SRE1)=$P($G(^SRF(SRTN,SRL(1),SRE,SRL(2),SRE1,SRL(3))),"^",SRP)
..I SRS=1 D
...I $P(SRFF,",",2)=.01 S ^TMP("SRASAVE",$J,SRTN,SRCAT,SRE,0,SRSUB)=$G(^SRF(SRTN,SRL(1),SRE,SRL(2),0))
...S ^TMP("SRASAVE",$J,SRTN,SRCAT,SRE,SRE1,SRSUB)=$P($G(^SRF(SRTN,SRL(1),SRE,SRL(2),SRE1,SRL(3))),"^",SRP)
..I $P(SRSUB,"-")'["X" S ^TMP("SRARAD"_SRS,$J,SRTN,SRCAT,SRE,SRE1,SRSUB)=$P($G(^SRF(SRTN,SRL(1),SRE,SRL(2),SRE1,SRL(3))),"^",SRP)
Q
REVRS ; restore pre-edit data in multiples
D REMOVE
S SRCAT="" F S SRCAT=$O(^TMP("SRARMULT1",$J,SRTN,SRCAT)) Q:SRCAT="" D RESTORE
Q
RESTORE ; enter multiple data saved in ^TMP("SRASAVE"
S (SRCNT,SRE)=0 F S SRE=$O(^TMP("SRASAVE",$J,SRTN,SRCAT,SRE)) Q:'SRE S SRE1="" F S SRE1=$O(^TMP("SRASAVE",$J,SRTN,SRCAT,SRE,SRE1)) Q:SRE1="" D
.S SRSUB="" F S SRSUB=$O(^TMP("SRASAVE",$J,SRTN,SRCAT,SRE,SRE1,SRSUB)) Q:SRSUB="" S SRCNT=SRCNT+1 D FIELD
Q
FIELD ; restore individual field
S X=$P(SRSUB,"-",3),SRFILE=$P(X,","),Y=$P(X,",",2),SRFIELD=$P(Y,";"),SRW=$S($P(Y,";",2)["W":1,1:0)
S:SRCNT=1 SRI="."_$P(SRFILE,".",2) S X=$E($P(SRSUB,"-"),1,2),SRJ=+X D REV^SROESAR1
S SRNP=$P(SRFLD,"^",3),SRN=$P(SRNP,";"),SRP=$P(SRNP,";",2)
K SRL F I=1:1 S Y=$P(SRN,",",I) Q:Y="" S SRL(I)=Y,SRL=I
I 'SRW S SRVAL=^TMP("SRASAVE",$J,SRTN,SRCAT,SRE,SRE1,SRSUB)
K DA,DIE,DR
I SRL=2,SRVAL'="" D
.I SRL(1)=13,SRL(2)=2 S ^SRF(SRTN,13,SRE,2)=SRVAL K DA,DIK S DA(1)=SRTN,DA=SRE,DIK="^SRF("_SRTN_",13,",DIK(1)="3" D EN^DIK K DA,DIK Q
.I SRE1=0,SRFIELD=.01 S ^SRF(SRTN,SRL(1),0)=^TMP("SRASAVE",$J,SRTN,SRCAT,0)
.S DA(1)=SRTN,DA=SRE,DIE="^SRF("_SRTN_","_$S(SRL(1):SRL(1),1:""""_SRL(1)_"""")_",",DR=SRFIELD_"////"_SRVAL D ^DIE K DA,DIE,DR
I SRL=3 D
.I SRE1=0,SRFIELD=.01,SRVAL'="" S ^SRF(SRTN,SRL(1),SRE,SRL(2),0)=SRVAL Q
.I SRW D Q
..S ^SRF(SRTN,SRL(1),SRE,SRL(2),0)=$G(^TMP("SRASAVE",$J,SRTN,SRCAT,SRE,SRE1,SRSUB,0))
..S SRLN=0 F S SRLN=$O(^TMP("SRASAVE",$J,SRTN,SRCAT,SRE,SRE1,SRSUB,SRLN)) Q:'SRLN S ^SRF(SRTN,SRL(1),SRE,SRL(2),SRLN,0)=$G(^TMP("SRASAVE",$J,SRTN,SRCAT,SRE,SRE1,SRSUB,SRLN))
.I SRVAL'="" S DA(2)=SRTN,DA(1)=SRE,DA=SRE1,DIE="^SRF("_SRTN_","_$S(SRL(1):SRL(1),1:""""_SRL(1)_"""")_","_SRE_","_$S(SRL(2):SRL(2),1:""""_SRL(2)_"""")_",",DR=SRFIELD_"////"_SRVAL D ^DIE K DA,DIE,DR
Q
REMOVE ; delete edited multiples
S SRCAT="" F S SRCAT=$O(^TMP("SRARMULT1",$J,SRTN,SRCAT)) Q:SRCAT="" S SRE=$O(^TMP("SRARMULT1",$J,SRTN,SRCAT,0)) Q:'SRE S SRE1="",SRE1=$O(^TMP("SRARMULT1",$J,SRTN,SRCAT,SRE,SRE1)) Q:SRE1="" D
.S SRSUB="",SRSUB=$O(^TMP("SRARMULT1",$J,SRTN,SRCAT,SRE,SRE1,SRSUB))
.S SRFF=$P(SRSUB,"-",3),SRK=$P(SRFF,","),SRI="."_$P(SRK,".",2),SRJ=1 D REV^SROESAR1
.S SRNP=$P(SRFLD,"^",3),SRN=$P(SRNP,";"),SRP=$P(SRNP,";",2)
.K SRL F I=1:1 S Y=$P(SRN,",",I) Q:Y="" S SRL(I)=Y,SRL=I
.D DEL
Q
DEL ; delete all entries from multiple
K DA,DIK S SRIEN=0 F S SRIEN=$O(^SRF(SRTN,SRL(1),SRIEN)) Q:'SRIEN S DA(1)=SRTN,DA=SRIEN,DIK="^SRF("_DA(1)_","_$S(SRL(1):SRL(1),1:""""_SRL(1)_"""")_"," D ^DIK K DA,DIK
K ^SRF(SRTN,SRL(1))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSROESARA 4431 printed Oct 16, 2024@18:44:08 Page 2
SROESARA ;BIR/ADM - ANESTHESIA REPORT E-SIG UTILITY ; [ 02/21/01 9:08 AM ]
+1 ;;3.0; Surgery ;**100**;24 Jun 93
+2 ;
+3 ;** NOTICE: This routine is part of an implementation of a nationally
+4 ;** controlled procedure. Local modifications to this routine
+5 ;** are prohibited.
+6 ;
MULT ; process multiples
+1 SET X=$PIECE(SRFLD,"^",2)
SET Y=$PIECE(SRFLD,"^",3)
IF $PIECE(X,";")=0
if SRS=1
SET ^TMP("SRASAVE",$JOB,SRTN,$PIECE(SRFLD,"^"),0)=$GET(^SRF(SRTN,$PIECE(Y,","),0))
QUIT
+2 SET SRCAT=$PIECE(SRFLD,"^")
SET SRSUB=$PIECE(SRFLD,"^",2)
SET SRFF=$PIECE(SRSUB,"-",3)
+3 SET SRNP=$PIECE(SRFLD,"^",3)
SET SRN=$PIECE(SRNP,";")
SET SRP=$PIECE(SRNP,";",2)
+4 KILL SRL
FOR I=1:1
SET Y=$PIECE(SRN,",",I)
if Y=""
QUIT
SET SRL(I)=Y
SET SRL=I
+5 SET SRW=$SELECT($PIECE(SRFF,";",2)["W":1,1:0)
+6 SET SRE=0
FOR
SET SRE=$ORDER(^SRF(SRTN,SRL(1),SRE))
if 'SRE
QUIT
Begin DoDot:1
+7 IF SRL=2
Begin DoDot:2
+8 IF SRS=1
Begin DoDot:3
+9 IF $PIECE(SRFF,",",2)=.01
SET ^TMP("SRASAVE",$JOB,SRTN,SRCAT,0)=$GET(^SRF(SRTN,SRL(1),0))
+10 SET ^TMP("SRASAVE",$JOB,SRTN,SRCAT,SRE,0,SRSUB)=$PIECE($GET(^SRF(SRTN,SRL(1),SRE,SRL(2))),"^",SRP)
End DoDot:3
+11 IF $PIECE(SRSUB,"-")'["X"
SET ^TMP("SRARAD"_SRS,$JOB,SRTN,SRCAT,SRE,0,SRSUB)=$PIECE($GET(^SRF(SRTN,SRL(1),SRE,SRL(2))),"^",SRP)
End DoDot:2
+12 IF SRL=3
SET SRE1=0
FOR
SET SRE1=$ORDER(^SRF(SRTN,SRL(1),SRE,SRL(2),SRE1))
if 'SRE1
QUIT
Begin DoDot:2
+13 IF SRW
Begin DoDot:3
+14 IF SRS=1
Begin DoDot:4
+15 SET ^TMP("SRASAVE",$JOB,SRTN,SRCAT,SRE,0,SRSUB,0)=$GET(^SRF(SRTN,SRL(1),SRE,SRL(2),0))
+16 SET ^TMP("SRASAVE",$JOB,SRTN,SRCAT,SRE,0,SRSUB,SRE1)=$PIECE($GET(^SRF(SRTN,SRL(1),SRE,SRL(2),SRE1,SRL(3))),"^",SRP)
End DoDot:4
+17 IF $PIECE(SRSUB,"-")'["X"
SET ^TMP("SRARAD"_SRS,$JOB,SRTN,SRCAT,SRE,0,SRSUB,SRE1)=$PIECE($GET(^SRF(SRTN,SRL(1),SRE,SRL(2),SRE1,SRL(3))),"^",SRP)
End DoDot:3
QUIT
+18 IF SRS=1
Begin DoDot:3
+19 IF $PIECE(SRFF,",",2)=.01
SET ^TMP("SRASAVE",$JOB,SRTN,SRCAT,SRE,0,SRSUB)=$GET(^SRF(SRTN,SRL(1),SRE,SRL(2),0))
+20 SET ^TMP("SRASAVE",$JOB,SRTN,SRCAT,SRE,SRE1,SRSUB)=$PIECE($GET(^SRF(SRTN,SRL(1),SRE,SRL(2),SRE1,SRL(3))),"^",SRP)
End DoDot:3
+21 IF $PIECE(SRSUB,"-")'["X"
SET ^TMP("SRARAD"_SRS,$JOB,SRTN,SRCAT,SRE,SRE1,SRSUB)=$PIECE($GET(^SRF(SRTN,SRL(1),SRE,SRL(2),SRE1,SRL(3))),"^",SRP)
End DoDot:2
End DoDot:1
+22 QUIT
REVRS ; restore pre-edit data in multiples
+1 DO REMOVE
+2 SET SRCAT=""
FOR
SET SRCAT=$ORDER(^TMP("SRARMULT1",$JOB,SRTN,SRCAT))
if SRCAT=""
QUIT
DO RESTORE
+3 QUIT
RESTORE ; enter multiple data saved in ^TMP("SRASAVE"
+1 SET (SRCNT,SRE)=0
FOR
SET SRE=$ORDER(^TMP("SRASAVE",$JOB,SRTN,SRCAT,SRE))
if 'SRE
QUIT
SET SRE1=""
FOR
SET SRE1=$ORDER(^TMP("SRASAVE",$JOB,SRTN,SRCAT,SRE,SRE1))
if SRE1=""
QUIT
Begin DoDot:1
+2 SET SRSUB=""
FOR
SET SRSUB=$ORDER(^TMP("SRASAVE",$JOB,SRTN,SRCAT,SRE,SRE1,SRSUB))
if SRSUB=""
QUIT
SET SRCNT=SRCNT+1
DO FIELD
End DoDot:1
+3 QUIT
FIELD ; restore individual field
+1 SET X=$PIECE(SRSUB,"-",3)
SET SRFILE=$PIECE(X,",")
SET Y=$PIECE(X,",",2)
SET SRFIELD=$PIECE(Y,";")
SET SRW=$SELECT($PIECE(Y,";",2)["W":1,1:0)
+2 if SRCNT=1
SET SRI="."_$PIECE(SRFILE,".",2)
SET X=$EXTRACT($PIECE(SRSUB,"-"),1,2)
SET SRJ=+X
DO REV^SROESAR1
+3 SET SRNP=$PIECE(SRFLD,"^",3)
SET SRN=$PIECE(SRNP,";")
SET SRP=$PIECE(SRNP,";",2)
+4 KILL SRL
FOR I=1:1
SET Y=$PIECE(SRN,",",I)
if Y=""
QUIT
SET SRL(I)=Y
SET SRL=I
+5 IF 'SRW
SET SRVAL=^TMP("SRASAVE",$JOB,SRTN,SRCAT,SRE,SRE1,SRSUB)
+6 KILL DA,DIE,DR
+7 IF SRL=2
IF SRVAL'=""
Begin DoDot:1
+8 IF SRL(1)=13
IF SRL(2)=2
SET ^SRF(SRTN,13,SRE,2)=SRVAL
KILL DA,DIK
SET DA(1)=SRTN
SET DA=SRE
SET DIK="^SRF("_SRTN_",13,"
SET DIK(1)="3"
DO EN^DIK
KILL DA,DIK
QUIT
+9 IF SRE1=0
IF SRFIELD=.01
SET ^SRF(SRTN,SRL(1),0)=^TMP("SRASAVE",$JOB,SRTN,SRCAT,0)
+10 SET DA(1)=SRTN
SET DA=SRE
SET DIE="^SRF("_SRTN_","_$SELECT(SRL(1):SRL(1),1:""""_SRL(1)_"""")_","
SET DR=SRFIELD_"////"_SRVAL
DO ^DIE
KILL DA,DIE,DR
End DoDot:1
+11 IF SRL=3
Begin DoDot:1
+12 IF SRE1=0
IF SRFIELD=.01
IF SRVAL'=""
SET ^SRF(SRTN,SRL(1),SRE,SRL(2),0)=SRVAL
QUIT
+13 IF SRW
Begin DoDot:2
+14 SET ^SRF(SRTN,SRL(1),SRE,SRL(2),0)=$GET(^TMP("SRASAVE",$JOB,SRTN,SRCAT,SRE,SRE1,SRSUB,0))
+15 SET SRLN=0
FOR
SET SRLN=$ORDER(^TMP("SRASAVE",$JOB,SRTN,SRCAT,SRE,SRE1,SRSUB,SRLN))
if 'SRLN
QUIT
SET ^SRF(SRTN,SRL(1),SRE,SRL(2),SRLN,0)=$GET(^TMP("SRASAVE",$JOB,SRTN,SRCAT,SRE,SRE1,SRSUB,SRLN))
End DoDot:2
QUIT
+16 IF SRVAL'=""
SET DA(2)=SRTN
SET DA(1)=SRE
SET DA=SRE1
SET DIE="^SRF("_SRTN_","_$SELECT(SRL(1):SRL(1),1:""""_SRL(1)_"""")_","_SRE_","_$SELECT(SRL(2):SRL(2),1:""""_SRL(2)_"""")_","
SET DR=SRFIELD_"////"_SRVAL
DO ^DIE
KILL DA,DIE,DR
End DoDot:1
+17 QUIT
REMOVE ; delete edited multiples
+1 SET SRCAT=""
FOR
SET SRCAT=$ORDER(^TMP("SRARMULT1",$JOB,SRTN,SRCAT))
if SRCAT=""
QUIT
SET SRE=$ORDER(^TMP("SRARMULT1",$JOB,SRTN,SRCAT,0))
if 'SRE
QUIT
SET SRE1=""
SET SRE1=$ORDER(^TMP("SRARMULT1",$JOB,SRTN,SRCAT,SRE,SRE1))
if SRE1=""
QUIT
Begin DoDot:1
+2 SET SRSUB=""
SET SRSUB=$ORDER(^TMP("SRARMULT1",$JOB,SRTN,SRCAT,SRE,SRE1,SRSUB))
+3 SET SRFF=$PIECE(SRSUB,"-",3)
SET SRK=$PIECE(SRFF,",")
SET SRI="."_$PIECE(SRK,".",2)
SET SRJ=1
DO REV^SROESAR1
+4 SET SRNP=$PIECE(SRFLD,"^",3)
SET SRN=$PIECE(SRNP,";")
SET SRP=$PIECE(SRNP,";",2)
+5 KILL SRL
FOR I=1:1
SET Y=$PIECE(SRN,",",I)
if Y=""
QUIT
SET SRL(I)=Y
SET SRL=I
+6 DO DEL
End DoDot:1
+7 QUIT
DEL ; delete all entries from multiple
+1 KILL DA,DIK
SET SRIEN=0
FOR
SET SRIEN=$ORDER(^SRF(SRTN,SRL(1),SRIEN))
if 'SRIEN
QUIT
SET DA(1)=SRTN
SET DA=SRIEN
SET DIK="^SRF("_DA(1)_","_$SELECT(SRL(1):SRL(1),1:""""_SRL(1)_"""")_","
DO ^DIK
KILL DA,DIK
+2 KILL ^SRF(SRTN,SRL(1))
+3 QUIT
