SROAPCA4 ;BIR/SJA - CARDIAC COMPLIANCE DATA ;09/01/2011
;;3.0;Surgery;**95,125,153,174,176,177**;24 Jun 93;Build 89
;
; Reference to ^DGPM("APTT1" supported by DBIA #565
; Reference to File #405 supported by DBIA #3029
; Reference to Field #27.02 in File #2 supported by DBIA #1850
;
S SRA(201)=$G(^SRF(SRTN,201)),SRA(202)=$G(^SRF(SRTN,202)),SRA(208)=$G(^SRF(SRTN,208)),SRA(0)=$G(^SRF(SRTN,0)),SRA(202.1)=$G(^SRF(SRTN,202.1))
N SRPREF,SRREF,SRREFP,SRFOL,SRFOLP,SRSOUT,SRY S (SRPREF,SRREF,SRREFP,SRFOL,SRFOLP)="",SRSOUT=0,(VAIP("D"),SRSDATE)=$P(SRA(0),"^",9) D IN5^VADPT
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) TS S VAIP("D")=SRDT D IN5^VADPT
TS I VAIP(13) K DA,DIC,DIQ,DR S DIC=405,DR=.05,DA=VAIP(13),DIQ="SRY",DIQ(0)="IE" D EN^DIQ1 S SRREF=SRY(405,VAIP(13),.05,"E"),SRREFP=SRY(405,VAIP(13),.05,"I") I SRREFP S SRREFP=$$GET1^DIQ(4,SRREFP,99)
I VAIP(17) K DA,DIC,DIQ,DR,SRY S DIC=405,DR=.05,DA=VAIP(17),DIQ="SRY",DIQ(0)="IE" D EN^DIQ1 S SRFOL=SRY(405,VAIP(17),.05,"E"),SRFOLP=SRY(405,VAIP(17),.05,"I") I SRFOLP S SRFOLP=$$GET1^DIQ(4,SRFOLP,99)
K DA,DIC,DIQ,DR,SRY S DIC="^DPT(",DIQ="SRY",DIQ(0)="I",DA=DFN,DR=27.02 D EN^DIQ1 S X=$G(SRY(2,DFN,27.02,"I")) I X S SRPREF=$$GET1^DIQ(4,X,99)
I $Y+7>IOSL D PAGE^SROAPCA I SRSOUT Q
D DD
Q
LAB ;D PAGE^SROAPCA I SRSOUT Q
W !!,"III. DETAILED LABORATORY INFO - PREOPERATIVE VALUES"
N SROUN S SROUN=" mg/dl"
W !,"Creatinine:",?14,$J($P(SRA(201),U,4),4),SROUN S Y=$P(SRA(202),"^",4) D DT W ?25,"("_$E(X,1,8)_")"
W ?41,"T. Cholesterol:",?57,$J($P(SRA(201),U,26),4),SROUN S Y=$P(SRA(202),"^",26) D DT W ?68,"("_$E(X,1,8)_")"
W !,"Hemoglobin:",?14,$J($P(SRA(201),U,20),4),SROUN S Y=$P(SRA(202),"^",20) D DT W ?25,"("_$E(X,1,8)_")"
W ?41,"HDL:",?57,$J($P(SRA(201),U,21),4),SROUN S Y=$P(SRA(202),"^",22) D DT W ?68,"("_$E(X,1,8)_")"
W !,"Albumin:",?14,$J($P(SRA(201),U,8),4)," g/dl" S Y=$P(SRA(202),"^",8) D DT W ?25,"("_$E(X,1,8)_")"
W ?41,"LDL:",?57,$J($P(SRA(201),U,25),4),SROUN S Y=$P(SRA(202),"^",25) D DT W ?68,"("_$E(X,1,8)_")"
W !,"Triglyceride:",?14,$J($P(SRA(201),U,22),4),SROUN S Y=$P(SRA(202),"^",22) D DT W ?25,"("_$E(X,1,8)_")"
W ?41,"Hemoglobin A1c:",?57,$J($P(SRA(201),U,28),4)," %" S Y=$P(SRA(202.1),"^") D DT W ?68,"("_$E(X,1,8)_")"
W !,"Potassium:",?14,$J($P(SRA(201),U,23),4)," mg/L" S Y=$P(SRA(202),"^",23) D DT W ?25,"("_$E(X,1,8)_")"
W ?41,"BNP:",?57,$J($P(SRA(201),U,29),4),SROUN S Y=$P(SRA(202.1),"^",2) D DT W ?68,"("_$E(X,1,8)_")"
W !,"T. Bilirubin:",?14,$J($P(SRA(201),U,24),4),SROUN S Y=$P(SRA(202),"^",24) D DT W ?25,"("_$E(X,1,8)_")"
Q
DD ;Detailed Discharge Information
N VAINDT,SRPTF,SRRES
S X=$P(SRA(208),"^",15) I X S X=X-.01 ;AAS - Patch 177 - Date needs to be at least .01 less than discharge date.
S VAINDT=X D INP^VADPT S SRPTF=VAIN(10)
S SRRES="" D RPC^DGPTFAPI(.SRRES,SRPTF)
I $Y+9>IOSL D PAGE^SROAPCA I SRSOUT Q
W !!,"X. DETAILED DISCHARGE INFORMATION",!," Discharge ICD-"_$$ICD910^SROICD(SRTN)_" Codes: " I $G(SRRES(0))>0 S SRRES="" D
.S SRRES=$P(SRRES(1),U,3)_" " I $D(SRRES(2)) F I=1:1:9 S:$P(SRRES(2),"^",I)'="" SRRES=SRRES_$P(SRRES(2),"^",I)_" " I $L(SRRES)>45 W SRRES S SRRES=""
.W:$D(SRRES) !,?26,SRRES
W !!,"Type of Disposition: ",$P($G(SRRES(1)),U,1)
W !,"Place of Disposition: ",$P($G(SRRES(1)),U,2)
W !,"Preferred VAMC identification code: ",SRPREF
W !,"Primary care or referral VAMC identification code: ",SRREFP
W !,"Follow-up VAMC identification code: ",SRFOLP
Q
YN ; store answer
S SHEMP=$S(NYUK="NS":"NS",NYUK="N":"NO",NYUK="Y":"YES",1:"")
Q
DT S X="NS" I Y>1 D DT^SROAPCA1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSROAPCA4 3650 printed Nov 22, 2024@17:51:31 Page 2
SROAPCA4 ;BIR/SJA - CARDIAC COMPLIANCE DATA ;09/01/2011
+1 ;;3.0;Surgery;**95,125,153,174,176,177**;24 Jun 93;Build 89
+2 ;
+3 ; Reference to ^DGPM("APTT1" supported by DBIA #565
+4 ; Reference to File #405 supported by DBIA #3029
+5 ; Reference to Field #27.02 in File #2 supported by DBIA #1850
+6 ;
+7 SET SRA(201)=$GET(^SRF(SRTN,201))
SET SRA(202)=$GET(^SRF(SRTN,202))
SET SRA(208)=$GET(^SRF(SRTN,208))
SET SRA(0)=$GET(^SRF(SRTN,0))
SET SRA(202.1)=$GET(^SRF(SRTN,202.1))
+8 NEW SRPREF,SRREF,SRREFP,SRFOL,SRFOLP,SRSOUT,SRY
SET (SRPREF,SRREF,SRREFP,SRFOL,SRFOLP)=""
SET SRSOUT=0
SET (VAIP("D"),SRSDATE)=$PIECE(SRA(0),"^",9)
DO IN5^VADPT
+9 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 TS
SET VAIP("D")=SRDT
DO IN5^VADPT
TS IF VAIP(13)
KILL DA,DIC,DIQ,DR
SET DIC=405
SET DR=.05
SET DA=VAIP(13)
SET DIQ="SRY"
SET DIQ(0)="IE"
DO EN^DIQ1
SET SRREF=SRY(405,VAIP(13),.05,"E")
SET SRREFP=SRY(405,VAIP(13),.05,"I")
IF SRREFP
SET SRREFP=$$GET1^DIQ(4,SRREFP,99)
+1 IF VAIP(17)
KILL DA,DIC,DIQ,DR,SRY
SET DIC=405
SET DR=.05
SET DA=VAIP(17)
SET DIQ="SRY"
SET DIQ(0)="IE"
DO EN^DIQ1
SET SRFOL=SRY(405,VAIP(17),.05,"E")
SET SRFOLP=SRY(405,VAIP(17),.05,"I")
IF SRFOLP
SET SRFOLP=$$GET1^DIQ(4,SRFOLP,99)
+2 KILL DA,DIC,DIQ,DR,SRY
SET DIC="^DPT("
SET DIQ="SRY"
SET DIQ(0)="I"
SET DA=DFN
SET DR=27.02
DO EN^DIQ1
SET X=$GET(SRY(2,DFN,27.02,"I"))
IF X
SET SRPREF=$$GET1^DIQ(4,X,99)
+3 IF $Y+7>IOSL
DO PAGE^SROAPCA
IF SRSOUT
QUIT
+4 DO DD
+5 QUIT
LAB ;D PAGE^SROAPCA I SRSOUT Q
+1 WRITE !!,"III. DETAILED LABORATORY INFO - PREOPERATIVE VALUES"
+2 NEW SROUN
SET SROUN=" mg/dl"
+3 WRITE !,"Creatinine:",?14,$JUSTIFY($PIECE(SRA(201),U,4),4),SROUN
SET Y=$PIECE(SRA(202),"^",4)
DO DT
WRITE ?25,"("_$EXTRACT(X,1,8)_")"
+4 WRITE ?41,"T. Cholesterol:",?57,$JUSTIFY($PIECE(SRA(201),U,26),4),SROUN
SET Y=$PIECE(SRA(202),"^",26)
DO DT
WRITE ?68,"("_$EXTRACT(X,1,8)_")"
+5 WRITE !,"Hemoglobin:",?14,$JUSTIFY($PIECE(SRA(201),U,20),4),SROUN
SET Y=$PIECE(SRA(202),"^",20)
DO DT
WRITE ?25,"("_$EXTRACT(X,1,8)_")"
+6 WRITE ?41,"HDL:",?57,$JUSTIFY($PIECE(SRA(201),U,21),4),SROUN
SET Y=$PIECE(SRA(202),"^",22)
DO DT
WRITE ?68,"("_$EXTRACT(X,1,8)_")"
+7 WRITE !,"Albumin:",?14,$JUSTIFY($PIECE(SRA(201),U,8),4)," g/dl"
SET Y=$PIECE(SRA(202),"^",8)
DO DT
WRITE ?25,"("_$EXTRACT(X,1,8)_")"
+8 WRITE ?41,"LDL:",?57,$JUSTIFY($PIECE(SRA(201),U,25),4),SROUN
SET Y=$PIECE(SRA(202),"^",25)
DO DT
WRITE ?68,"("_$EXTRACT(X,1,8)_")"
+9 WRITE !,"Triglyceride:",?14,$JUSTIFY($PIECE(SRA(201),U,22),4),SROUN
SET Y=$PIECE(SRA(202),"^",22)
DO DT
WRITE ?25,"("_$EXTRACT(X,1,8)_")"
+10 WRITE ?41,"Hemoglobin A1c:",?57,$JUSTIFY($PIECE(SRA(201),U,28),4)," %"
SET Y=$PIECE(SRA(202.1),"^")
DO DT
WRITE ?68,"("_$EXTRACT(X,1,8)_")"
+11 WRITE !,"Potassium:",?14,$JUSTIFY($PIECE(SRA(201),U,23),4)," mg/L"
SET Y=$PIECE(SRA(202),"^",23)
DO DT
WRITE ?25,"("_$EXTRACT(X,1,8)_")"
+12 WRITE ?41,"BNP:",?57,$JUSTIFY($PIECE(SRA(201),U,29),4),SROUN
SET Y=$PIECE(SRA(202.1),"^",2)
DO DT
WRITE ?68,"("_$EXTRACT(X,1,8)_")"
+13 WRITE !,"T. Bilirubin:",?14,$JUSTIFY($PIECE(SRA(201),U,24),4),SROUN
SET Y=$PIECE(SRA(202),"^",24)
DO DT
WRITE ?25,"("_$EXTRACT(X,1,8)_")"
+14 QUIT
DD ;Detailed Discharge Information
+1 NEW VAINDT,SRPTF,SRRES
+2 ;AAS - Patch 177 - Date needs to be at least .01 less than discharge date.
SET X=$PIECE(SRA(208),"^",15)
IF X
SET X=X-.01
+3 SET VAINDT=X
DO INP^VADPT
SET SRPTF=VAIN(10)
+4 SET SRRES=""
DO RPC^DGPTFAPI(.SRRES,SRPTF)
+5 IF $Y+9>IOSL
DO PAGE^SROAPCA
IF SRSOUT
QUIT
+6 WRITE !!,"X. DETAILED DISCHARGE INFORMATION",!," Discharge ICD-"_$$ICD910^SROICD(SRTN)_" Codes: "
IF $GET(SRRES(0))>0
SET SRRES=""
Begin DoDot:1
+7 SET SRRES=$PIECE(SRRES(1),U,3)_" "
IF $DATA(SRRES(2))
FOR I=1:1:9
if $PIECE(SRRES(2),"^",I)'=""
SET SRRES=SRRES_$PIECE(SRRES(2),"^",I)_" "
IF $LENGTH(SRRES)>45
WRITE SRRES
SET SRRES=""
+8 if $DATA(SRRES)
WRITE !,?26,SRRES
End DoDot:1
+9 WRITE !!,"Type of Disposition: ",$PIECE($GET(SRRES(1)),U,1)
+10 WRITE !,"Place of Disposition: ",$PIECE($GET(SRRES(1)),U,2)
+11 WRITE !,"Preferred VAMC identification code: ",SRPREF
+12 WRITE !,"Primary care or referral VAMC identification code: ",SRREFP
+13 WRITE !,"Follow-up VAMC identification code: ",SRFOLP
+14 QUIT
YN ; store answer
+1 SET SHEMP=$SELECT(NYUK="NS":"NS",NYUK="N":"NO",NYUK="Y":"YES",1:"")
+2 QUIT
DT SET X="NS"
IF Y>1
DO DT^SROAPCA1
+1 QUIT
