SRTPUTL ;BIR/SJA - UTILITY ROUTINE ;02/27/2008
;;3.0; Surgery ;**167**;24 Jun 93;Build 27
;
; Reference to EN1^GMRVUT0 supported by DBIA #1446
;
ADT ; set 'ADT x-ref
S SRINVDT=9999999-X S ^SRT("ADT",$P(^SRT(DA,0),"^"),SRINVDT,DA)=X K SRINVDT
Q
KADT ; kill 'ADT' x-ref
S SRINVDT=9999999-X K ^SRT("ADT",$P(^SRT(DA,0),"^"),SRINVDT,DA),SRINVDT
Q
AT ; set logic for AT x-ref on DATE OF LAST TRANSMISSION
N SRX S ^SRT("AT",X,DA)=""
S SRX=$P($G(^SRT(DA,"RA")),"^",4) I SRX,SRX'=X K ^SRT("AT",SRX,DA)
Q
KAT ; kill logic for AT x-ref on DATE OF LAST TRANSMISSION
N SRX K ^SRT("AT",X,DA)
S SRX=$P($G(^SRT(DA,"RA")),"^",4) I SRX,SRX'=X K ^SRT("AT",SRX,DA)
Q
AGE ; set logic of the 'AGE' x-ref on the Donor's Date of Birth
N DOB,DOT
S SRTPP=$S($D(SRTPP):SRTPP,1:DA)
S DOB=$P($G(^SRT(SRTPP,1)),"^"),DOT=$P($G(^SRT(SRTPP,0)),"^",2)
I DOB&DOT S $P(^SRT(SRTPP,1),"^",6)=(($$FMDIFF^XLFDT(DOT,DOB))\365.25)
Q
KAGE ; 'KILL' logic of the 'AGE' x-ref on the Date of Birth
S SRTPP=$S($D(SRTPP):SRTPP,1:DA),$P(^SRT(SRTPP,1),"^",6)=""
Q
Y Q:'$D(X) I X'?.N1"Y"&(X'?.N1"y"),(+X'=X) K X Q
S:X["y" X=+X_"Y"
Q
HLA ; called by input transform of the HLA TYPING fields
N SRX S SRX=X K:'(X?.4N.2(1",".4N))!'($TR(X,",")) X S:SRX="NS"!(SRX="ns") X="NS"
Q
PVR ; called by input transform of the PVR VASODILATION fields
N SRX,SRY S SRX=X K:+X'=X!(X>9.9)!(X<0)!(X?.E1"."2.N) X S:SRX="NS"!(SRX="ns") X="NS"
I +DR=163,$P($G(^SRT(SRTPP,.01)),"^",6)="NS" S SRY=1
I +DR=164,$P($G(^SRT(SRTPP,.01)),"^",5)="NS" S SRY=1
I $G(SRY)=1,SRX="NS" D EN^DDIOL("'NS' is only allowed in one of the PVR fields!",,"!,?2") K X D RET^SRTPCOM Q
Q
HW ; get weight & height from Vitals
N SREND,SREQ,SREX,SREY,SRSTRT
WT I $P($G(^SRT(SRTPP,0)),"^",5)="" D
.S SREND=$P($G(^SRT(SRTPP,0)),"^",2),SRSTRT=$$FMADD^XLFDT(SREND,-30),SREX=$$HW^SROACL1(SRSTRT,SREND,"WT")
.I SREX'="" S SREX=SREX+.5\1 D CHK^DIE(139.5,5,"E",SREX,.SREY) I SREY'="^" S $P(^SRT(SRTPP,0),"^",5)=SREY
HT I $P($G(^SRT(SRTPP,0)),"^",4)'="" Q
N GMRVSTR,SRBRDT,SRBIEN,SRBDATA,SRHTDT
K ^UTILITY($J,"GMRVD"),RESULTS S SREND=$P($G(^SRT(SRTPP,0)),"^",2),GMRVSTR="HT",GMRVSTR(0)="^"_SREND_"^^0"
D EN1^GMRVUT0 Q:'$D(^UTILITY($J,"GMRVD"))
S SRBRDT="",SRBRDT=$O(^UTILITY($J,"GMRVD","HT",SRBRDT)) Q:'SRBRDT D
.S SRBIEN=0 F S SRBIEN=$O(^UTILITY($J,"GMRVD","HT",SRBRDT,SRBIEN)) Q:'SRBIEN D
..S SRBDATA=$G(^UTILITY($J,"GMRVD","HT",SRBRDT,SRBIEN)),SREX=$P(SRBDATA,"^",8)
..I SREX'="" S SREX=SREX+.5\1 D CHK^DIE(139.5,4,"E",SREX,.SREY) I SREY'="^" D
...S $P(^SRT(SRTPP,0),"^",4)=SREY
Q
F69(SRTPP) ; restrict selection of DCD & SCD for heart transplant
N SROK S SROK=1
I $P($G(^SRT(SRTPP,"RA")),"^",2)="H" I Y=2!(Y=4) S SROK=0
Q SROK
F147(SRTPP) ; screen out DIET for Lung, Liver, and Kidney
N SROK S SROK=1
I $P($G(^SRT(SRTPP,"RA")),"^",2)]"",$P($G(^SRT(SRTPP,"RA")),"^",2)'="H" I Y="D" S SROK=0
Q SROK
HDR ; print screen header
W @IOF,!,SRHDR W:$G(SRPAGE)'="" ?(79-$L(SRPAGE)),SRPAGE
S I=0 F S I=$O(SRHDR(I)) Q:'I W !,SRHDR(I) I I=1,$L($G(SRHPG)) W ?(79-$L(SRHPG)),SRHPG
K SRHPG,SRPAGE W ! F I=1:1:80 W "-"
W !
Q
SRHDR N X,I K SRHDR S DFN=$P(^SRT(SRTPP,0),"^"),SRCASE=$P(^SRT(SRTPP,0),"^",3),SRVACO=$P($G(^SRT(SRTPP,.01)),"^",11) D DEM^VADPT
S SRHDR=VADM(1)_" ("_$P(VA("PID"),"-",3)_") VACO ID: "_SRVACO_$S('SRNOVA:" CASE: "_SRCASE,1:"")
S Y=$P(^SRT(SRTPP,0),"^",2) X ^DD("DD") S SRSDATE=Y
S I=$P($G(^SRT(SRTPP,"RA")),"^",2),SROPER=$$TR(I)_" TRANSPLANT"
S SROPER=SROPER S SRHDR(1)=SRSDATE_" "_SROPER
Q
TR(SRI) ;
Q $S(SRI="K":"KIDNEY",SRI="LI":"LIVER",SRI="LU":"LUNG",SRI="H":"HEART",1:"")
SRTPUTL ;BIR/SJA - UTILITY ROUTINE ;02/27/2008
+1 ;;3.0; Surgery ;**167**;24 Jun 93;Build 27
+2 ;
+3 ; Reference to EN1^GMRVUT0 supported by DBIA #1446
+4 ;
ADT ; set 'ADT x-ref
+1 SET SRINVDT=9999999-X
SET ^SRT("ADT",$PIECE(^SRT(DA,0),"^"),SRINVDT,DA)=X
KILL SRINVDT
+2 QUIT
KADT ; kill 'ADT' x-ref
+1 SET SRINVDT=9999999-X
KILL ^SRT("ADT",$PIECE(^SRT(DA,0),"^"),SRINVDT,DA),SRINVDT
+2 QUIT
AT ; set logic for AT x-ref on DATE OF LAST TRANSMISSION
+1 NEW SRX
SET ^SRT("AT",X,DA)=""
+2 SET SRX=$PIECE($GET(^SRT(DA,"RA")),"^",4)
IF SRX
IF SRX'=X
KILL ^SRT("AT",SRX,DA)
+3 QUIT
KAT ; kill logic for AT x-ref on DATE OF LAST TRANSMISSION
+1 NEW SRX
KILL ^SRT("AT",X,DA)
+2 SET SRX=$PIECE($GET(^SRT(DA,"RA")),"^",4)
IF SRX
IF SRX'=X
KILL ^SRT("AT",SRX,DA)
+3 QUIT
AGE ; set logic of the 'AGE' x-ref on the Donor's Date of Birth
+1 NEW DOB,DOT
+2 SET SRTPP=$SELECT($DATA(SRTPP):SRTPP,1:DA)
+3 SET DOB=$PIECE($GET(^SRT(SRTPP,1)),"^")
SET DOT=$PIECE($GET(^SRT(SRTPP,0)),"^",2)
+4 IF DOB&DOT
SET $PIECE(^SRT(SRTPP,1),"^",6)=(($$FMDIFF^XLFDT(DOT,DOB))\365.25)
+5 QUIT
KAGE ; 'KILL' logic of the 'AGE' x-ref on the Date of Birth
+1 SET SRTPP=$SELECT($DATA(SRTPP):SRTPP,1:DA)
SET $PIECE(^SRT(SRTPP,1),"^",6)=""
+2 QUIT
Y IF '$DATA(X)
QUIT
IF X'?.N1"Y"&(X'?.N1"y")
IF (+X'=X)
KILL X
QUIT
+1 IF X["y"
SET X=+X_"Y"
+2 QUIT
HLA ; called by input transform of the HLA TYPING fields
+1 NEW SRX
SET SRX=X
IF '(X?.4N.2(1",".4N))!'($TRANSLATE(X,","))
KILL X
IF SRX="NS"!(SRX="ns")
SET X="NS"
+2 QUIT
PVR ; called by input transform of the PVR VASODILATION fields
+1 NEW SRX,SRY
SET SRX=X
IF +X'=X!(X>9.9)!(X<0)!(X?.E1"."2.N)
KILL X
IF SRX="NS"!(SRX="ns")
SET X="NS"
+2 IF +DR=163
IF $PIECE($GET(^SRT(SRTPP,.01)),"^",6)="NS"
SET SRY=1
+3 IF +DR=164
IF $PIECE($GET(^SRT(SRTPP,.01)),"^",5)="NS"
SET SRY=1
+4 IF $GET(SRY)=1
IF SRX="NS"
DO EN^DDIOL("'NS' is only allowed in one of the PVR fields!",,"!,?2")
KILL X
DO RET^SRTPCOM
QUIT
+5 QUIT
HW ; get weight & height from Vitals
+1 NEW SREND,SREQ,SREX,SREY,SRSTRT
WT IF $PIECE($GET(^SRT(SRTPP,0)),"^",5)=""
Begin DoDot:1
+1 SET SREND=$PIECE($GET(^SRT(SRTPP,0)),"^",2)
SET SRSTRT=$$FMADD^XLFDT(SREND,-30)
SET SREX=$$HW^SROACL1(SRSTRT,SREND,"WT")
+2 IF SREX'=""
SET SREX=SREX+.5\1
DO CHK^DIE(139.5,5,"E",SREX,.SREY)
IF SREY'="^"
SET $PIECE(^SRT(SRTPP,0),"^",5)=SREY
End DoDot:1
HT IF $PIECE($GET(^SRT(SRTPP,0)),"^",4)'=""
QUIT
+1 NEW GMRVSTR,SRBRDT,SRBIEN,SRBDATA,SRHTDT
+2 KILL ^UTILITY($JOB,"GMRVD"),RESULTS
SET SREND=$PIECE($GET(^SRT(SRTPP,0)),"^",2)
SET GMRVSTR="HT"
SET GMRVSTR(0)="^"_SREND_"^^0"
+3 DO EN1^GMRVUT0
IF '$DATA(^UTILITY($JOB,"GMRVD"))
QUIT
+4 SET SRBRDT=""
SET SRBRDT=$ORDER(^UTILITY($JOB,"GMRVD","HT",SRBRDT))
IF 'SRBRDT
QUIT
Begin DoDot:1
+5 SET SRBIEN=0
FOR
SET SRBIEN=$ORDER(^UTILITY($JOB,"GMRVD","HT",SRBRDT,SRBIEN))
IF 'SRBIEN
QUIT
Begin DoDot:2
+6 SET SRBDATA=$GET(^UTILITY($JOB,"GMRVD","HT",SRBRDT,SRBIEN))
SET SREX=$PIECE(SRBDATA,"^",8)
+7 IF SREX'=""
SET SREX=SREX+.5\1
DO CHK^DIE(139.5,4,"E",SREX,.SREY)
IF SREY'="^"
Begin DoDot:3
+8 SET $PIECE(^SRT(SRTPP,0),"^",4)=SREY
End DoDot:3
End DoDot:2
End DoDot:1
+9 QUIT
F69(SRTPP) ; restrict selection of DCD & SCD for heart transplant
+1 NEW SROK
SET SROK=1
+2 IF $PIECE($GET(^SRT(SRTPP,"RA")),"^",2)="H"
IF Y=2!(Y=4)
SET SROK=0
+3 QUIT SROK
F147(SRTPP) ; screen out DIET for Lung, Liver, and Kidney
+1 NEW SROK
SET SROK=1
+2 IF $PIECE($GET(^SRT(SRTPP,"RA")),"^",2)]""
IF $PIECE($GET(^SRT(SRTPP,"RA")),"^",2)'="H"
IF Y="D"
SET SROK=0
+3 QUIT SROK
HDR ; print screen header
+1 WRITE @IOF,!,SRHDR
IF $GET(SRPAGE)'=""
WRITE ?(79-$LENGTH(SRPAGE)),SRPAGE
+2 SET I=0
FOR
SET I=$ORDER(SRHDR(I))
IF 'I
QUIT
WRITE !,SRHDR(I)
IF I=1
IF $LENGTH($GET(SRHPG))
WRITE ?(79-$LENGTH(SRHPG)),SRHPG
+3 KILL SRHPG,SRPAGE
WRITE !
FOR I=1:1:80
WRITE "-"
+4 WRITE !
+5 QUIT
SRHDR NEW X,I
KILL SRHDR
SET DFN=$PIECE(^SRT(SRTPP,0),"^")
SET SRCASE=$PIECE(^SRT(SRTPP,0),"^",3)
SET SRVACO=$PIECE($GET(^SRT(SRTPP,.01)),"^",11)
DO DEM^VADPT
+1 SET SRHDR=VADM(1)_" ("_$PIECE(VA("PID"),"-",3)_") VACO ID: "_SRVACO_$SELECT('SRNOVA:" CASE: "_SRCASE,1:"")
+2 SET Y=$PIECE(^SRT(SRTPP,0),"^",2)
XECUTE ^DD("DD")
SET SRSDATE=Y
+3 SET I=$PIECE($GET(^SRT(SRTPP,"RA")),"^",2)
SET SROPER=$$TR(I)_" TRANSPLANT"
+4 SET SROPER=SROPER
SET SRHDR(1)=SRSDATE_" "_SROPER
+5 QUIT
TR(SRI) ;
+1 QUIT $SELECT(SRI="K":"KIDNEY",SRI="LI":"LIVER",SRI="LU":"LUNG",SRI="H":"HEART",1:"")
