Routine: SROAPCA4

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

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)_")"

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

YN ; store answer

 S SHEMP=$S(NYUK="NS":"NS",NYUK="N":"NO",NYUK="Y":"YES",1:"")

DT S X="NS" I Y>1 D DT^SROAPCA1

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSROAPCA4   3650     printed  Apr 23, 2025@18:56:11                                                                                                                                                                                                    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

SROAPCA4.m