SROAPIMS ;BIR/ADM - PIMS Information Retrieval ;01/24/07
;;3.0;Surgery;**38,46,47,57,71,81,86,100,125,134,160,175,182,184,185**;24 Jun 93;Build 2
;
; Reference to ^MCAR(690,"AC" supported by DBIA #80
; Reference to ^DGPM("APTT1" supported by DBIA #565
;
; SRTN must be defined before calling this routine.
; This routine will return the following array
; SRVADPT(1) = Name of the patient (e.g., SMITH,JOHN R.)
; SRVADPT(2) = Patient ID (e.g., 123-45-6789)
; SRVADPT(3) = Age of patient on date of operation (e.g., 36)
; SRVADPT(4) = Sex of patient (e.g., M^MALE)
; SRVADPT(5) = Race of patient (e.g., 6^WHITE, NOT OF HISPANIC ORIGIN)
; SRVADPT(6) = Date of death
; SRVADPT(7) = Hospital admission date
; SRVADPT(8) = Hospital discharge date
; SRVADPT(9) = Admission/transfer to surgical specialty
; SRVADPT(10) = Discharge/tranfer to chronic care
; SRVADPT(11) = Length of Post-Operative Hospital Stay (number of days)
; SRVADPT(12) = Admission to Observation
; SRVADPT(13) = Discharge from Observation
; SRVADPT(14) = Observation Specialty (PTF #)
; SRVADPT(15) = Bad Address Indicator
;
N SR,SRCC,SRDT,SRNON,SRSRV S SR(0)=^SRF(SRTN,0),DFN=$P(SR(0),"^") F I=1:1:15 S SRVADPT(I)=""
D DEM^VADPT S SRVADPT(1)=VADM(1),SRVADPT(2)=VA("PID"),SRVADPT(4)=VADM(5),SRVADPT(6)=VADM(6) S Y=$E($P(SR(0),"^",9),1,7),Z=$P(VADM(3),"^") S SRVADPT(3)=$E(Y,1,3)-$E(Z,1,3)-($E(Y,4,7)<$E(Z,4,7))
S SRX=$P(VADM(8),"^") I SRX K DA,DIC,DIQ,DR,SRY S DIC=10,DR=2,DA=SRX,DIQ="SRY",DIQ(0)="I" D EN^DIQ1 S SRVADPT(5)=SRY(10,SRX,2,"I")_"^"_$P(VADM(8),"^",2)
S SRVADPT(15)=$$BADADR^DGUTL3(DFN),$P(^SRF(SRTN,209),"^")=$S(SRVADPT(15):"Y",1:"N")
ADM ; find date(s) of admission and discharge
N SRSOUT S SRSOUT=0,(VAIP("D"),SRSDATE)=$P(SR(0),"^",9) D IN5^VADPT
; if not admitted before surgery, look for admission within 24 hours of leaving OR
I 'VAIP(13) S X1=$P($G(^SRF(SRTN,.2)),"^",12),X2=1 D C^%DTC S SR24=X,SRDT=$O(^DGPM("APTT1",DFN,SRSDATE)) G:'SRDT!(SRDT>SR24) END S VAIP("D")=SRDT D IN5^VADPT I 'VAIP(13) G END
I VAIP(13) D ADM1 G:SRSOUT END
ADSS ; find date of admission/transfer to surgical service
S SRSERV="" I VAIP(1) S SRX=$P(VAIP(8),"^") D SERV G:'SRSRV DISSS S:$P(VAIP(2),"^")=1 SRVADPT(9)=$E($P(VAIP(3),"^"),1,12) I $P(VAIP(2),"^")'=1 S SRSERV=$P(VAIP(3),"^")
I VAIP(15) D PRIOR
DISSS ; find date of discharge/transfer to chronic care
S SRNON=0,SRCC="",VAIP("D")=SRSAVE D IN5^VADPT
FOLLOW I VAIP(16) D I 'SRNON S SRCC=VAIP(16,1),VAIP("D")=$P(SRCC,"^") D IN5^VADPT G FOLLOW
.I $P(VAIP(16,2),"^")=3 S SRNON=1 Q
.I "26"[$P(VAIP(16,2),"^") S SRX=$P(VAIP(16,6),"^") D NACUTE
S SRVADPT(10)=SRVADPT(8) I SRNON S SRVADPT(10)=$E($P(VAIP(16,1),"^"),1,12)
STAY ; find length of post-operative hospital stay
S X=$P($G(^SRF(SRTN,.2)),"^",3),X1=$P(SRVADPT(10),"^") I 'X!('X1)!(X>X1) G END
S Y=$E(X1_"000",9,10)-$E(X_"000",9,10)*60+$E(X1_"00000",11,12)-$E(X_"00000",11,12),X2=X,X=$P(X,".",1)'=$P(X1,".",1) D ^%DTC:X S X=X*1440+Y,SRVADPT(11)=X\1440
END S $P(^SRF(SRTN,208),"^",10)=$P(SRVADPT(5),"^"),SRINOUT=$P(^SRF(SRTN,0),"^",12) I SRVADPT(7)'="",SRVADPT(9)="" S SRVADPT(9)=$P($G(^SRF(SRTN,.2)),"^",10)
F I=7:1:10,12,13 S X=$P(SRVADPT(I),"^") I $L(X)>7 S $P(SRVADPT(I),"^")=+X
I SRVADPT(7)'="" S $P(^SRF(SRTN,205),"^")=SRVADPT(11),L=6 F J=14:1:17 S L=L+1,$P(^SRF(SRTN,208),"^",J)=$P(SRVADPT(L),"^")
I SRVADPT(7)="" S $P(^SRF(SRTN,205),"^")=$S(SRINOUT="O"!(SRINOUT=1):"NA",1:SRVADPT(11)) S L=6 F J=14:1:17 S L=L+1 S $P(^SRF(SRTN,208),"^",J)=$S(SRINOUT="O"!(SRINOUT=1):"NA",1:$P(SRVADPT(L),"^"))
I SRVADPT(12)="" F J=1:1:3 S $P(^SRF(SRTN,208.1),"^",J)="NA"
S $P(^SRF(SRTN,205),"^",3)=$S($P(SRVADPT(6),"^")'="":$E($P(SRVADPT(6),"^"),1,12),1:"NA")
S $P(^SRF(SRTN,205),"^",41)=$S($P(SRVADPT(6),"^")="":"N",$$FMDIFF^XLFDT($P(SRVADPT(6),"^"),$P(^SRF(SRTN,.2),"^",3))>30:"N",1:"Y")
S $P(^SRF(SRTN,210),"^",14)=1
D MCAR,EMPLOY
D KVA^VADPT K DIE,DR,I,SR,SR24,SR48,SRCC,SRD,SRDD,SRDO,SRDT,SRF,SRINOUT,SRNON,SRSP,SRSRV,SRQ,SRX,SRY,X,X1,Y
Q
PRIOR ; loop through previous movements
S SRX=$P(VAIP(15,6),"^") D SERV D I SRSRV,VAIP(15) G PRIOR
.I SRSRV S SRSERV=VAIP(15,1),VAIP("D")=$P(SRSERV,"^") D IN5^VADPT Q
S SRVADPT(9)=$E($P(SRSERV,"^"),1,12)
Q
SERV ; find service associated with movement
S SRSRV="" D SPEC S Y="50,51,52,53,54,55,56,57,58,59,60,61,62,63" S:Y[SRSP SRSRV=1
Q
SPEC ; find specialty associated with movement
K DA,DIC,DIQ,DR,SRY S DIC=45.7,DR=1,DA=SRX,DIQ="SRY",DIQ(0)="I" D EN^DIQ1 S SRSP=SRY(45.7,SRX,1,"I") I SRSP,$L(SRSP)=1 S SRSP="0"_SRSP
Q
NACUTE ; determine if non-acute care transfer
D SPEC S Y="05,20,21,22,25,26,27,28,29,32,33,34,35,40,70,71,72,73,74,75,76,77,79,80,81,83,84,85,86,87,88,89,90,91,92,93,98,99" S:Y[SRSP SRNON=1
Q
MCAR S (SRD,SRF,SRQ)=0,DFN=$P(^SRF(SRTN,0),"^"),SRDO=$P(^SRF(SRTN,0),"^",9)
F S SRD=$O(^MCAR(690,"AC",DFN,SRD)) Q:SRD=""!(SRQ=9) S SRF=0 F S SRF=$O(^MCAR(690,"AC",DFN,SRD,SRF)) Q:SRF=""!(SRQ=9) I SRF="MCAR(691.1" D
.S SRDD=9999999.9999-SRD
.I SRDD<SRDO S $P(^SRF(SRTN,207),"^",21)=SRDD,SRQ=9
Q
EMPLOY ; employment status preoperatively
S DFN=$P(^SRF(SRTN,0),"^") D OPD^VADPT S $P(^SRF(SRTN,208),"^",18)=$P(VAPD(7),"^")
Q
ADM1 ; get information related to admission
; determine if admission was for observation
; quit if no specialty defined for admission
S SRX=$P($G(VAIP(13,6)),"^") I SRX="" S SRSOUT=1 Q
D SPEC S Y="18,23,24,36,41,65,94" I Y[SRSP D Q:$G(SRSOUT)
.S SRVADPT(14)=SRSP,SRVADPT(12)=$E($P(VAIP(13,1),"^"),1,12),SRVADPT(13)=$E($P(VAIP(17,1),"^"),1,12)
.S I=1 F J=12:1:14 S $P(^SRF(SRTN,208.1),"^",I)=SRVADPT(J),I=I+1
.; look for admission following discharge from observation
.S X1=$P($G(^SRF(SRTN,.2)),"^",12),X2=2 D C^%DTC S SR48=X,SRDT=$O(^DGPM("APTT1",DFN,$P(VAIP(13,1),"^"))) I 'SRDT!(SRDT>SR48) S SRSOUT=1 Q
.S VAIP("D")=SRDT D IN5^VADPT I 'VAIP(13) S SRSOUT=1
S SRVADPT(7)=$E($P(VAIP(13,1),"^"),1,12),SRVADPT(8)=$E($P(VAIP(17,1),"^"),1,12),SRSAVE=$S(SRVADPT(7)<SRSDATE:SRSDATE,1:$P(VAIP(13,1),"^"))
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSROAPIMS 6007 printed Oct 16, 2024@18:42:13 Page 2
SROAPIMS ;BIR/ADM - PIMS Information Retrieval ;01/24/07
+1 ;;3.0;Surgery;**38,46,47,57,71,81,86,100,125,134,160,175,182,184,185**;24 Jun 93;Build 2
+2 ;
+3 ; Reference to ^MCAR(690,"AC" supported by DBIA #80
+4 ; Reference to ^DGPM("APTT1" supported by DBIA #565
+5 ;
+6 ; SRTN must be defined before calling this routine.
+7 ; This routine will return the following array
+8 ; SRVADPT(1) = Name of the patient (e.g., SMITH,JOHN R.)
+9 ; SRVADPT(2) = Patient ID (e.g., 123-45-6789)
+10 ; SRVADPT(3) = Age of patient on date of operation (e.g., 36)
+11 ; SRVADPT(4) = Sex of patient (e.g., M^MALE)
+12 ; SRVADPT(5) = Race of patient (e.g., 6^WHITE, NOT OF HISPANIC ORIGIN)
+13 ; SRVADPT(6) = Date of death
+14 ; SRVADPT(7) = Hospital admission date
+15 ; SRVADPT(8) = Hospital discharge date
+16 ; SRVADPT(9) = Admission/transfer to surgical specialty
+17 ; SRVADPT(10) = Discharge/tranfer to chronic care
+18 ; SRVADPT(11) = Length of Post-Operative Hospital Stay (number of days)
+19 ; SRVADPT(12) = Admission to Observation
+20 ; SRVADPT(13) = Discharge from Observation
+21 ; SRVADPT(14) = Observation Specialty (PTF #)
+22 ; SRVADPT(15) = Bad Address Indicator
+23 ;
+24 NEW SR,SRCC,SRDT,SRNON,SRSRV
SET SR(0)=^SRF(SRTN,0)
SET DFN=$PIECE(SR(0),"^")
FOR I=1:1:15
SET SRVADPT(I)=""
+25 DO DEM^VADPT
SET SRVADPT(1)=VADM(1)
SET SRVADPT(2)=VA("PID")
SET SRVADPT(4)=VADM(5)
SET SRVADPT(6)=VADM(6)
SET Y=$EXTRACT($PIECE(SR(0),"^",9),1,7)
SET Z=$PIECE(VADM(3),"^")
SET SRVADPT(3)=$EXTRACT(Y,1,3)-$EXTRACT(Z,1,3)-($EXTRACT(Y,4,7)<$EXTRACT(Z,4,7))
+26 SET SRX=$PIECE(VADM(8),"^")
IF SRX
KILL DA,DIC,DIQ,DR,SRY
SET DIC=10
SET DR=2
SET DA=SRX
SET DIQ="SRY"
SET DIQ(0)="I"
DO EN^DIQ1
SET SRVADPT(5)=SRY(10,SRX,2,"I")_"^"_$PIECE(VADM(8),"^",2)
+27 SET SRVADPT(15)=$$BADADR^DGUTL3(DFN)
SET $PIECE(^SRF(SRTN,209),"^")=$SELECT(SRVADPT(15):"Y",1:"N")
ADM ; find date(s) of admission and discharge
+1 NEW SRSOUT
SET SRSOUT=0
SET (VAIP("D"),SRSDATE)=$PIECE(SR(0),"^",9)
DO IN5^VADPT
+2 ; if not admitted before surgery, look for admission within 24 hours of leaving OR
+3 IF 'VAIP(13)
SET X1=$PIECE($GET(^SRF(SRTN,.2)),"^",12)
SET X2=1
DO C^%DTC
SET SR24=X
SET SRDT=$ORDER(^DGPM("APTT1",DFN,SRSDATE))
if 'SRDT!(SRDT>SR24)
GOTO END
SET VAIP("D")=SRDT
DO IN5^VADPT
IF 'VAIP(13)
GOTO END
+4 IF VAIP(13)
DO ADM1
if SRSOUT
GOTO END
ADSS ; find date of admission/transfer to surgical service
+1 SET SRSERV=""
IF VAIP(1)
SET SRX=$PIECE(VAIP(8),"^")
DO SERV
if 'SRSRV
GOTO DISSS
if $PIECE(VAIP(2),"^")=1
SET SRVADPT(9)=$EXTRACT($PIECE(VAIP(3),"^"),1,12)
IF $PIECE(VAIP(2),"^")'=1
SET SRSERV=$PIECE(VAIP(3),"^")
+2 IF VAIP(15)
DO PRIOR
DISSS ; find date of discharge/transfer to chronic care
+1 SET SRNON=0
SET SRCC=""
SET VAIP("D")=SRSAVE
DO IN5^VADPT
FOLLOW IF VAIP(16)
Begin DoDot:1
+1 IF $PIECE(VAIP(16,2),"^")=3
SET SRNON=1
QUIT
+2 IF "26"[$PIECE(VAIP(16,2),"^")
SET SRX=$PIECE(VAIP(16,6),"^")
DO NACUTE
End DoDot:1
IF 'SRNON
SET SRCC=VAIP(16,1)
SET VAIP("D")=$PIECE(SRCC,"^")
DO IN5^VADPT
GOTO FOLLOW
+3 SET SRVADPT(10)=SRVADPT(8)
IF SRNON
SET SRVADPT(10)=$EXTRACT($PIECE(VAIP(16,1),"^"),1,12)
STAY ; find length of post-operative hospital stay
+1 SET X=$PIECE($GET(^SRF(SRTN,.2)),"^",3)
SET X1=$PIECE(SRVADPT(10),"^")
IF 'X!('X1)!(X>X1)
GOTO END
+2 SET Y=$EXTRACT(X1_"000",9,10)-$EXTRACT(X_"000",9,10)*60+$EXTRACT(X1_"00000",11,12)-$EXTRACT(X_"00000",11,12)
SET X2=X
SET X=$PIECE(X,".",1)'=$PIECE(X1,".",1)
if X
DO ^%DTC
SET X=X*1440+Y
SET SRVADPT(11)=X\1440
END SET $PIECE(^SRF(SRTN,208),"^",10)=$PIECE(SRVADPT(5),"^")
SET SRINOUT=$PIECE(^SRF(SRTN,0),"^",12)
IF SRVADPT(7)'=""
IF SRVADPT(9)=""
SET SRVADPT(9)=$PIECE($GET(^SRF(SRTN,.2)),"^",10)
+1 FOR I=7:1:10,12,13
SET X=$PIECE(SRVADPT(I),"^")
IF $LENGTH(X)>7
SET $PIECE(SRVADPT(I),"^")=+X
+2 IF SRVADPT(7)'=""
SET $PIECE(^SRF(SRTN,205),"^")=SRVADPT(11)
SET L=6
FOR J=14:1:17
SET L=L+1
SET $PIECE(^SRF(SRTN,208),"^",J)=$PIECE(SRVADPT(L),"^")
+3 IF SRVADPT(7)=""
SET $PIECE(^SRF(SRTN,205),"^")=$SELECT(SRINOUT="O"!(SRINOUT=1):"NA",1:SRVADPT(11))
SET L=6
FOR J=14:1:17
SET L=L+1
SET $PIECE(^SRF(SRTN,208),"^",J)=$SELECT(SRINOUT="O"!(SRINOUT=1):"NA",1:$PIECE(SRVADPT(L),"^"))
+4 IF SRVADPT(12)=""
FOR J=1:1:3
SET $PIECE(^SRF(SRTN,208.1),"^",J)="NA"
+5 SET $PIECE(^SRF(SRTN,205),"^",3)=$SELECT($PIECE(SRVADPT(6),"^")'="":$EXTRACT($PIECE(SRVADPT(6),"^"),1,12),1:"NA")
+6 SET $PIECE(^SRF(SRTN,205),"^",41)=$SELECT($PIECE(SRVADPT(6),"^")="":"N",$$FMDIFF^XLFDT($PIECE(SRVADPT(6),"^"),$PIECE(^SRF(SRTN,.2),"^",3))>30:"N",1:"Y")
+7 SET $PIECE(^SRF(SRTN,210),"^",14)=1
+8 DO MCAR
DO EMPLOY
+9 DO KVA^VADPT
KILL DIE,DR,I,SR,SR24,SR48,SRCC,SRD,SRDD,SRDO,SRDT,SRF,SRINOUT,SRNON,SRSP,SRSRV,SRQ,SRX,SRY,X,X1,Y
+10 QUIT
PRIOR ; loop through previous movements
+1 SET SRX=$PIECE(VAIP(15,6),"^")
DO SERV
Begin DoDot:1
+2 IF SRSRV
SET SRSERV=VAIP(15,1)
SET VAIP("D")=$PIECE(SRSERV,"^")
DO IN5^VADPT
QUIT
End DoDot:1
IF SRSRV
IF VAIP(15)
GOTO PRIOR
+3 SET SRVADPT(9)=$EXTRACT($PIECE(SRSERV,"^"),1,12)
+4 QUIT
SERV ; find service associated with movement
+1 SET SRSRV=""
DO SPEC
SET Y="50,51,52,53,54,55,56,57,58,59,60,61,62,63"
if Y[SRSP
SET SRSRV=1
+2 QUIT
SPEC ; find specialty associated with movement
+1 KILL DA,DIC,DIQ,DR,SRY
SET DIC=45.7
SET DR=1
SET DA=SRX
SET DIQ="SRY"
SET DIQ(0)="I"
DO EN^DIQ1
SET SRSP=SRY(45.7,SRX,1,"I")
IF SRSP
IF $LENGTH(SRSP)=1
SET SRSP="0"_SRSP
+2 QUIT
NACUTE ; determine if non-acute care transfer
+1 DO SPEC
SET Y="05,20,21,22,25,26,27,28,29,32,33,34,35,40,70,71,72,73,74,75,76,77,79,80,81,83,84,85,86,87,88,89,90,91,92,93,98,99"
if Y[SRSP
SET SRNON=1
+2 QUIT
MCAR SET (SRD,SRF,SRQ)=0
SET DFN=$PIECE(^SRF(SRTN,0),"^")
SET SRDO=$PIECE(^SRF(SRTN,0),"^",9)
+1 FOR
SET SRD=$ORDER(^MCAR(690,"AC",DFN,SRD))
if SRD=""!(SRQ=9)
QUIT
SET SRF=0
FOR
SET SRF=$ORDER(^MCAR(690,"AC",DFN,SRD,SRF))
if SRF=""!(SRQ=9)
QUIT
IF SRF="MCAR(691.1"
Begin DoDot:1
+2 SET SRDD=9999999.9999-SRD
+3 IF SRDD<SRDO
SET $PIECE(^SRF(SRTN,207),"^",21)=SRDD
SET SRQ=9
End DoDot:1
+4 QUIT
EMPLOY ; employment status preoperatively
+1 SET DFN=$PIECE(^SRF(SRTN,0),"^")
DO OPD^VADPT
SET $PIECE(^SRF(SRTN,208),"^",18)=$PIECE(VAPD(7),"^")
+2 QUIT
ADM1 ; get information related to admission
+1 ; determine if admission was for observation
+2 ; quit if no specialty defined for admission
+3 SET SRX=$PIECE($GET(VAIP(13,6)),"^")
IF SRX=""
SET SRSOUT=1
QUIT
+4 DO SPEC
SET Y="18,23,24,36,41,65,94"
IF Y[SRSP
Begin DoDot:1
+5 SET SRVADPT(14)=SRSP
SET SRVADPT(12)=$EXTRACT($PIECE(VAIP(13,1),"^"),1,12)
SET SRVADPT(13)=$EXTRACT($PIECE(VAIP(17,1),"^"),1,12)
+6 SET I=1
FOR J=12:1:14
SET $PIECE(^SRF(SRTN,208.1),"^",I)=SRVADPT(J)
SET I=I+1
+7 ; look for admission following discharge from observation
+8 SET X1=$PIECE($GET(^SRF(SRTN,.2)),"^",12)
SET X2=2
DO C^%DTC
SET SR48=X
SET SRDT=$ORDER(^DGPM("APTT1",DFN,$PIECE(VAIP(13,1),"^")))
IF 'SRDT!(SRDT>SR48)
SET SRSOUT=1
QUIT
+9 SET VAIP("D")=SRDT
DO IN5^VADPT
IF 'VAIP(13)
SET SRSOUT=1
End DoDot:1
if $GET(SRSOUT)
QUIT
+10 SET SRVADPT(7)=$EXTRACT($PIECE(VAIP(13,1),"^"),1,12)
SET SRVADPT(8)=$EXTRACT($PIECE(VAIP(17,1),"^"),1,12)
SET SRSAVE=$SELECT(SRVADPT(7)<SRSDATE:SRSDATE,1:$PIECE(VAIP(13,1),"^"))
