SROGMTS.m

SROGMTS ;BIR/ADM - SURGERY HEALTH SUMMARY ; [ 08/08/01  7:12 AM ]

 ;;3.0; Surgery ;**100,127,162**;24 Jun 93;Build 4

 ;

 ;** NOTICE: This routine is part of an implementation of a nationally

 ;**         controlled procedure.  Local modifications to this routine

 ;**         are prohibited.

 ;

 ; Reference to $$MOD^ICPTMOD supported by DBIA #1996

 ; Reference to $$CPT^ICPTCOD supported by DBIA #1995

 ;

 Q

HS(X) ; return case information for a surical or non-OR case

 ; X - case number (IEN) in file 130

 K REC N SRCPTM,SRSG,DA,DR,DIC,DIQ,IEN,IENS,FILE,FLD,FLDS,FLDI

 N FLDA,FLDB,FLDR,FLDRT,IEN,SRI,SRRT,SRT,SRS,SRC,SRCS

 S SRCPTM=1

 Q:'$D(^SRF(X,0))  S (IENS,IEN,X)=+($G(X)),U="^"

 S:'$D(DT) DT=$$HTFM^XLFDT($H,1) S:'$D(DTIME) DTIME=300

 S (FILE,DIC)=130,DA=+($G(X)),DIQ="REC(",DIQ(0)="IE"

 S SRSG=$$SG(IEN),REC(130,IEN,118,"E")=$S(SRSG=0:"YES",1:""),REC(130,IEN,118,"I")=$S(SRSG=0:"Y",1:"")

 S:+SRSG DR=".09;.04;.14;.164;.205;.22;.23;.31;10;15;17;26;27;32;34;36;39;43;49;50"

 S:'SRSG DR=".09;.31;26;27;33;50;55;59;66;121;122;123;124;125"

 D EN^DIQ1 S REC(130,IEN,"STATUS")=$$OS(IEN) S:+SRSG REC(130,IEN,"VERIFIED")=$S($G(REC(130,IEN,43,"I"))'="Y":"(Unverified)",1:"")

 S SRM=$G(REC(130,IEN,27,"I")) I SRM>0 D CPT(SRM,$P($G(^SRF(IEN,0)),"^",9),130,27)

 D DICT^SROGMTS0,SUB,SPD

 S:$D(REC(130,IEN,32)) REC(130,IEN,32,"S")=$$EN2^SROGMTS0($G(REC(130,IEN,32,"E")))

 S:$D(REC(130,IEN,33)) REC(130,IEN,33,"S")=$$EN2^SROGMTS0($G(REC(130,IEN,33,"E")))

 S:$D(REC(130,IEN,34)) REC(130,IEN,34,"S")=$$EN2^SROGMTS0($G(REC(130,IEN,34,"E")))

 S:$D(REC(130,IEN,.04)) REC(130,IEN,.04,"S")=$$EN2^SROGMTS0($G(REC(130,IEN,.04,"E")))

 S:$D(REC(130,IEN,125)) REC(130,IEN,125,"S")=$$EN2^SROGMTS0($G(REC(130,IEN,125,"E")))

 I $L($G(REC(130,IEN,33,"S"))) D

 . S:'$L($G(REC(130,IEN,66,"E"))) REC(130,IEN,33,"S")=$G(REC(130,IEN,33,"S"))_" (Unknown)"

 . S:$L($G(REC(130,IEN,66,"E"))) REC(130,IEN,33,"S")=$G(REC(130,IEN,33,"S"))_" (ICD "_$G(REC(130,IEN,66,"E"))_")"

 S:+($G(REC(130,IEN,.09,"I")))>0 REC(130,IEN,.09,"S")=$$ED^SROGMTS0($G(REC(130,IEN,.09,"I")))

 S:+($G(REC(130,IEN,15,"I")))>0 REC(130,IEN,15,"S")=$$EDT^SROGMTS0($G(REC(130,IEN,15,"I")))

 S:+($G(REC(130,IEN,39,"I"))) REC(130,IEN,39,"S")=$$EDT^SROGMTS0($G(REC(130,IEN,39,"I")))

 S:+SRSG REC(130,IEN,"LAB")=$S($O(REC(130,IEN,49,0))>0:"Yes",1:"")

 I 'SRSG D:+($O(REC(130,IEN,55,0)))>0 WP(IEN,55,58) D:+($O(REC(130,IEN,59,0)))>0 WP(IEN,59,58)

 Q

ED(X) ; external date

 S X=$G(X) Q:'$L(X) ""

 S X=$TR($$FMTE^XLFDT(X,"5DZ"),"@"," ")

 Q X

EDT(X) ; external date and time

 S X=$G(X) Q:'$L(X) ""

 S X=$TR($$FMTE^XLFDT(X,"2ZM"),"@"," ")

 Q X

WP(X,Y,Z) ;

 N SRI,SRF,SRW,SRGI,DIWF,DIWL,DIWR

 S SRI=+($G(X)) Q:SRI=0!('$D(REC(130,SRI)))

 S SRF=+($G(Y)) Q:SRF=0!('$D(REC(130,SRI,SRF)))

 S SRW=+($G(Z)) Q:SRW'>0!(SRW>79)

 Q:+($O(REC(130,SRI,SRF,0)))'>0

 K ^UTILITY($J,"W") S DIWF="C"_SRW,DIWL=0,DIWR=0,SRGI=0

 F  S SRGI=$O(REC(130,SRI,SRF,SRGI)) Q:+SRGI=0  D

 . S X=$G(REC(130,SRI,SRF,SRGI))

 . D ^DIWP

 S SRGI=0 F  S SRGI=$O(^UTILITY($J,"W",0,SRGI)) Q:+SRGI=0  D

 . S REC(130,SRI,SRF,"S",SRGI)=$G(^UTILITY($J,"W",0,SRGI,0))

 . S REC(130,SRI,SRF,"S",0)=$G(REC(130,SRI,SRF,"S",0))+1

 K ^UTILITY($J,"W")

 Q

OS(X) ; Obtains status for OR procedures

 N SRN S SRN=+($G(X)) S X="" I $G(REC(130,SRN,118,"I"))="Y" D  Q X

 . S:+($G(REC(130,SRN,122,"I")))>0 X="(Completed)"

 . S:+($G(REC(130,SRN,121,"I")))>0&(+($G(REC(130,SRN,122,"I")))'>0) X="Incomplete"

 . S:X="" X="Unknown"

 I +($G(REC(130,SRN,17,"I")))>0 D  Q X

 . S X=$S(+($G(REC(130,SRN,.205,"I")))>0:"(Aborted)",1:"Cancelled")

 I +($G(REC(130,SRN,.23,"I")))>0 S X="(Completed)" Q X

 I +($G(REC(130,SRN,.22,"I")))>0 S X="Incomplete" Q X

 I +($G(REC(130,SRN,10,"I")))>0 S X="Scheduled" Q X

 I +($G(REC(130,SRN,36,"I")))>0,+($G(REC(130,SRN,.22,"I")))'>0 S X="Requested" Q X

 S X="Unknown"

 Q X

SUB ;

 N DA,DR,DIC,DIQ,IENS,FILE,FLD,FLDS,FLDI,FLDA,FLDB,FLDR,FLDRT,SRM,SRC,SRI,SRJ,STXT,SNAM,SCOD,SUB

 I +SRSG D

 . ;

 . ; ^SRF(DO,14,I)                .72  Other Preop Diag    14;0  130.17

 . ; $P(^SRF(DO,14,I,0),U)        .01  Other Preop Diag     0;1  Text

 . ;

 . S DA=IEN,(FILE,DIC)=130,SUB=130.17,DR=.72,DR(SUB)=".01",DIQ="REC(130,"_IEN_",",DIQ(0)="IE"

 . K REC(SUB) S SRI=0 F  S SRI=$O(^SRF(+($G(IEN)),14,SRI)) Q:+SRI=0  D

 . . S DA(SUB)=SRI

 . . D EN^DIQ1

 . . S REC(130,IEN,130.17,SRI,.01,"S")=$$EN2^SROGMTS0($G(REC(130,IEN,130.17,SRI,.01,"E")))

 . ;

 . ; ^SRF(DO,15,I)                .74  Other Postop Diags  15;0  130.18

 . ; $P(^SRF(DO,15,I,0),U)        .01  Other Postop Diags   0;1  Text

 . ;

 . S DA=IEN,(FILE,DIC)=130,SUB=130.18,DR=.74,DR(SUB)=".01",DIQ="REC(130,"_IEN_",",DIQ(0)="IE"

 . K REC(SUB) S SRI=0 F  S SRI=$O(^SRF(+($G(IEN)),15,SRI)) Q:+SRI=0  D

 . . S DA(SUB)=SRI

 . . D EN^DIQ1

 . . S REC(130,IEN,130.18,SRI,.01,"S")=$$EN2^SROGMTS0($G(REC(130,IEN,130.18,SRI,.01,"E")))

 ;

 ; ^SRF(SRN,"OPMOD",I)           28  Pri Pro CPT Mod  OPMOD;0  130.028

 ; $P(^SRF(SRN,"OPMOD",I,0),U)  .01  Pri Pro CPT Mod      0;1  Ptr 81.3

 ;

 I SRCPTM D

 . S DA=IEN,(FILE,DIC)=130,SUB=130.028,DR=28,DR(SUB)=".01",DIQ="REC(130,"_IEN_",",DIQ(0)="IE"

 . K REC(SUB) S SRI=0 F  S SRI=$O(^SRF(+($G(IEN)),"OPMOD",SRI)) Q:+SRI=0  D

 . . S DA(SUB)=SRI

 . . D EN^DIQ1

 . . S SRM=+($G(REC(130,+($G(IEN)),SUB,+($G(SRI)),.01,"I"))) I SRM>0 D MOD(SRM,FILE,SUB)

 ;

 ; ^SRF(DO,13,I)                .42  Other Proc          13;0  130.16

 ; $P(^SRF(DO,13,I,0),U)        .01  Other Proc           0;1  Text      

 ; $P(^SRF(DO,13,I,2),U)          3  Other Proc CPT Code  2;1  Ptr 81

 ;

 S DA=IEN,(FILE,DIC)=130,SUB=130.16,DR=.42,DR(SUB)=".01;3",DIQ="REC(130,"_IEN_",",DIQ(0)="IE"

 K REC(SUB) S SRI=0 F  S SRI=$O(^SRF(+($G(IEN)),13,SRI)) Q:+SRI=0  D

 . S DA(SUB)=SRI

 . D EN^DIQ1 S SRM=+($G(REC(130,IEN,130.16,SRI,3,"I")))

 . S:SRM>0 REC(130,IEN,130.16,SRI,3,"N")=$P($$CPT^ICPTCOD(+SRM,$P($G(^SRF(IEN,0)),"^",9)),"^",3)

 . N SRT,SRS,SRC S SRM=$G(REC(130,IEN,130.16,SRI,3,"I")) I SRM>0 D

 . . S SRC=$$CPT^ICPTCOD(SRM,$P($G(^SRF(IEN,0)),"^",9)),(SRCS,SRS)=$$EN2^SROGMTS0($P(SRC,"^",3))

 . . S REC(130,IEN,130.16,SRI,3,"X")=$P(SRC,"^",2)_"^"_$P(SRC,"^",3)

 . . S SRC=$P(SRC,"^",2)

 . . S SRT=$$EN2^SROGMTS0($G(REC(130,IEN,130.16,SRI,.01,"E")))

 . . S:$L(SRS)&(SRS'=SRT) SRT=SRT_" - "_$$EN2^SROGMTS0(SRS)

 . . S:$L(SRC)=5 SRT=SRT_" (CPT "_SRC_")",SRCS=SRCS_" (CPT "_SRC_")"

 . . S REC(130,IEN,130.16,SRI,3,"N")=SRS

 . . S REC(130,IEN,130.16,SRI,.01,"S")=SRT

 . . S REC(130,IEN,130.16,SRI,3,"S")=SRCS

 . ;

 . ;     ^SRF(8,13,2,"MOD",0)       4  Oth Proc CPT Mod   MOD;0  130.164

 . ;     ^SRF(8,13,2,"MOD",1,0)   .01  Oth Proc CPT Mod     0;1  Ptr 81.3

 . ;

 . I SRCPTM D

 . . N SRJ S SRJ=0 F  S SRJ=$O(^SRF(+($G(IEN)),13,SRI,"MOD",SRJ)) Q:+SRJ=0  D

 . . . N DA,FILE,DIC,SUB,DR,DIQ S DA=IEN,DR=.42,FILE=130,SUB=130.16,DR(SUB)="4",DA(SUB)=SRI,SUB=130.164,DR(SUB)=".01",DA(SUB)=SRJ,DIC=130,DIQ="REC(130,"_IEN_",130.16,"_SRI_",",DIQ(0)="IE"

 . . . D EN^DIQ1

 . . . S SRM=+($G(REC(130,IEN,130.16,SRI,130.164,SRJ,.01,"I")))

 . . . I SRM>0 N SRMOD1 D

 . . . . S SRMOD1=$$MOD^ICPTMOD(+SRM,"I",$P($G(^SRF(IEN,0)),"^",9))

 . . . . S SRC=$P(SRMOD1,"^",2)

 . . . . S SRS=$P(SRMOD1,"^",3)

 . . . . S REC(130,IEN,130.16,SRI,SUB,SRJ,.01,"MID")=SRC

 . . . . S REC(130,IEN,130.16,SRI,SUB,SRJ,.01,"MOD")=SRS

 . . . . S REC(130,IEN,130.16,SRI,SUB,SRJ,.01,"X")=SRC_"^"_SRS

 . . . . S SRT=$$EN2^SROGMTS0(SRS) S:$L(SRC) SRT=SRT_" (CPT Mod "_SRC_")"

 . . . . S REC(130,IEN,130.16,SRI,SUB,SRJ,.01,"S")=SRT

 . . . K REC(130,IEN,130.16,SRI,130)

 Q

SG(X) ; Surgical (Operative) Record

 S X=$$GET1^DIQ(130,+($G(X)),118,"I") S X=$S(X["Y":0,1:1) Q X

CPT(SRM,SRDOO,SRFIL,SRFLD) ;Set CPT code into REC array

 S SRC=$$CPT^ICPTCOD(SRM,SRDOO),(SRCS,SRS)=$$EN2^SROGMTS0($P(SRC,"^",3))

 S REC(SRFIL,IEN,SRFLD,"X")=$P(SRC,"^",2)_"^"_$P(SRC,"^",3)

 S SRC=$P(SRC,"^",2),SRT=$$EN2^SROGMTS0($G(REC(130,IEN,26,"E")))

 S:$L(SRS)&(SRS'=SRT) SRT=SRT_" - "_SRS

 S:$L(SRC)=5 SRT=SRT_" (CPT "_SRC_")",SRCS=SRCS_" (CPT "_SRC_")"

 S REC(SRFIL,IEN,SRFLD,"N")=SRS

 S:SRFIL=130 REC(130,IEN,26,"S")=SRT

 S REC(SRFIL,IEN,SRFLD,"S")=SRT

 S REC(SRFIL,IEN,SRFLD,"S")=SRCS

 Q

MOD(SRM,SRFIL,SUB) ;Set CPT Modifier into REC array

 S SRMOD=$$MOD^ICPTMOD(+SRM,"I",$P($G(^SRF(IEN,0)),"^",9))

 S SRC=$P(SRMOD,"^",2)

 S SRS=$P(SRMOD,"^",3)

 S REC(SRFIL,IEN,SUB,SRI,.01,"MID")=SRC

 S REC(SRFIL,IEN,SUB,SRI,.01,"MOD")=SRS

 S SRT=$$EN2^SROGMTS0(SRS)

 S:$L(SRC) SRT=SRT_" (CPT Mod "_SRC_")"

 S REC(SRFIL,IEN,SUB,SRI,.01,"S")=SRT

 Q

SPD ;Obtain Surgery Procedure/Diagnosis Code File entry

 S (FILE,DIC)=136,DA=+($G(IEN)),DIQ="REC(",DIQ(0)="IE"

 S DR=".01;.02;.03;10"

 D EN^DIQ1

 Q:'+$G(REC(FILE,IEN,10,"I"))

 S SRM=+$G(REC(FILE,IEN,.02,"I"))

 Q:'(SRM>0)  D CPT(SRM,$P($G(^SRF(IEN,0)),"^",9),FILE,.02)

 S SUB=136.01,DR=1,DR(SUB)=".01",DIQ="REC(136,"_IEN_","

 K REC(FILE,IEN,SUB) S SRI=0 F  S SRI=$O(^SRO(FILE,(+$G(IEN)),DR,SRI))  Q:+SRI=0  D

 .S DA(SUB)=SRI

 .D EN^DIQ1

 .S SRM=REC(FILE,IEN,SUB,SRI,.01,"I") I SRM>0 D MOD(SRM,FILE,SUB)

 N DA S DA=IEN,SUB=136.011,DR=11,DR(SUB)=".01;1"

 K REC(FILE,IEN,SUB) S SRI=0 F  S SRI=$O(^SRO(FILE,(+$G(IEN)),DR,SRI)) Q:+SRI=0  D

 . S DA(SUB)=SRI

 . D EN^DIQ1

 S $P(REC(130,IEN,26,"S"),"-",2)=" "_REC(FILE,IEN,.02,"S")

 K REC(130,IEN,130.028) M REC(130,IEN,130.028)=REC(FILE,IEN,136.01)

 Q

SROGMTS   ;BIR/ADM - SURGERY HEALTH SUMMARY ; [ 08/08/01  7:12 AM ]

 +1       ;;3.0; Surgery ;**100,127,162**;24 Jun 93;Build 4

 +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       ;

 +7       ; Reference to $$MOD^ICPTMOD supported by DBIA #1996

 +8       ; Reference to $$CPT^ICPTCOD supported by DBIA #1995

 +9       ;

 +10       QUIT 

HS(X)     ; return case information for a surical or non-OR case

 +1       ; X - case number (IEN) in file 130

 +2        KILL REC

           NEW SRCPTM,SRSG,DA,DR,DIC,DIQ,IEN,IENS,FILE,FLD,FLDS,FLDI

 +3        NEW FLDA,FLDB,FLDR,FLDRT,IEN,SRI,SRRT,SRT,SRS,SRC,SRCS

 +4        SET SRCPTM=1

 +5        IF '$DATA(^SRF(X,0))

               QUIT 

           SET (IENS,IEN,X)=+($GET(X))

           SET U="^"

 +6        IF '$DATA(DT)

               SET DT=$$HTFM^XLFDT($HOROLOG,1)

           IF '$DATA(DTIME)

               SET DTIME=300

 +7        SET (FILE,DIC)=130

           SET DA=+($GET(X))

           SET DIQ="REC("

           SET DIQ(0)="IE"

 +8        SET SRSG=$$SG(IEN)

           SET REC(130,IEN,118,"E")=$SELECT(SRSG=0:"YES",1:"")

           SET REC(130,IEN,118,"I")=$SELECT(SRSG=0:"Y",1:"")

 +9        IF +SRSG

               SET DR=".09;.04;.14;.164;.205;.22;.23;.31;10;15;17;26;27;32;34;36;39;43;49;50"

 +10       IF 'SRSG

               SET DR=".09;.31;26;27;33;50;55;59;66;121;122;123;124;125"

 +11       DO EN^DIQ1

           SET REC(130,IEN,"STATUS")=$$OS(IEN)

           IF +SRSG

               SET REC(130,IEN,"VERIFIED")=$SELECT($GET(REC(130,IEN,43,"I"))'="Y":"(Unverified)",1:"")

 +12       SET SRM=$GET(REC(130,IEN,27,"I"))

           IF SRM>0

               DO CPT(SRM,$PIECE($GET(^SRF(IEN,0)),"^",9),130,27)

 +13       DO DICT^SROGMTS0

           DO SUB

           DO SPD

 +14       IF $DATA(REC(130,IEN,32))

               SET REC(130,IEN,32,"S")=$$EN2^SROGMTS0($GET(REC(130,IEN,32,"E")))

 +15       IF $DATA(REC(130,IEN,33))

               SET REC(130,IEN,33,"S")=$$EN2^SROGMTS0($GET(REC(130,IEN,33,"E")))

 +16       IF $DATA(REC(130,IEN,34))

               SET REC(130,IEN,34,"S")=$$EN2^SROGMTS0($GET(REC(130,IEN,34,"E")))

 +17       IF $DATA(REC(130,IEN,.04))

               SET REC(130,IEN,.04,"S")=$$EN2^SROGMTS0($GET(REC(130,IEN,.04,"E")))

 +18       IF $DATA(REC(130,IEN,125))

               SET REC(130,IEN,125,"S")=$$EN2^SROGMTS0($GET(REC(130,IEN,125,"E")))

 +19       IF $LENGTH($GET(REC(130,IEN,33,"S")))

               Begin DoDot:1

 +20               IF '$LENGTH($GET(REC(130,IEN,66,"E")))

                       SET REC(130,IEN,33,"S")=$GET(REC(130,IEN,33,"S"))_" (Unknown)"

 +21               IF $LENGTH($GET(REC(130,IEN,66,"E")))

                       SET REC(130,IEN,33,"S")=$GET(REC(130,IEN,33,"S"))_" (ICD "_$GET(REC(130,IEN,66,"E"))_")"

               End DoDot:1

 +22       IF +($GET(REC(130,IEN,.09,"I")))>0

               SET REC(130,IEN,.09,"S")=$$ED^SROGMTS0($GET(REC(130,IEN,.09,"I")))

 +23       IF +($GET(REC(130,IEN,15,"I")))>0

               SET REC(130,IEN,15,"S")=$$EDT^SROGMTS0($GET(REC(130,IEN,15,"I")))

 +24       IF +($GET(REC(130,IEN,39,"I")))

               SET REC(130,IEN,39,"S")=$$EDT^SROGMTS0($GET(REC(130,IEN,39,"I")))

 +25       IF +SRSG

               SET REC(130,IEN,"LAB")=$SELECT($ORDER(REC(130,IEN,49,0))>0:"Yes",1:"")

 +26       IF 'SRSG

               IF +($ORDER(REC(130,IEN,55,0)))>0

                   DO WP(IEN,55,58)

               IF +($ORDER(REC(130,IEN,59,0)))>0

                   DO WP(IEN,59,58)

 +27       QUIT 

ED(X)     ; external date

 +1        SET X=$GET(X)

           IF '$LENGTH(X)

               QUIT ""

 +2        SET X=$TRANSLATE($$FMTE^XLFDT(X,"5DZ"),"@"," ")

 +3        QUIT X

EDT(X)    ; external date and time

 +1        SET X=$GET(X)

           IF '$LENGTH(X)

               QUIT ""

 +2        SET X=$TRANSLATE($$FMTE^XLFDT(X,"2ZM"),"@"," ")

 +3        QUIT X

WP(X,Y,Z) ;

 +1        NEW SRI,SRF,SRW,SRGI,DIWF,DIWL,DIWR

 +2        SET SRI=+($GET(X))

           IF SRI=0!('$DATA(REC(130,SRI)))

               QUIT 

 +3        SET SRF=+($GET(Y))

           IF SRF=0!('$DATA(REC(130,SRI,SRF)))

               QUIT 

 +4        SET SRW=+($GET(Z))

           IF SRW'>0!(SRW>79)

               QUIT 

 +5        IF +($ORDER(REC(130,SRI,SRF,0)))'>0

               QUIT 

 +6        KILL ^UTILITY($JOB,"W")

           SET DIWF="C"_SRW

           SET DIWL=0

           SET DIWR=0

           SET SRGI=0

 +7        FOR 

               SET SRGI=$ORDER(REC(130,SRI,SRF,SRGI))

               IF +SRGI=0

                   QUIT 

               Begin DoDot:1

 +8                SET X=$GET(REC(130,SRI,SRF,SRGI))

 +9                DO ^DIWP

               End DoDot:1

 +10       SET SRGI=0

           FOR 

               SET SRGI=$ORDER(^UTILITY($JOB,"W",0,SRGI))

               IF +SRGI=0

                   QUIT 

               Begin DoDot:1

 +11               SET REC(130,SRI,SRF,"S",SRGI)=$GET(^UTILITY($JOB,"W",0,SRGI,0))

 +12               SET REC(130,SRI,SRF,"S",0)=$GET(REC(130,SRI,SRF,"S",0))+1

               End DoDot:1

 +13       KILL ^UTILITY($JOB,"W")

 +14       QUIT 

OS(X)     ; Obtains status for OR procedures

 +1        NEW SRN

           SET SRN=+($GET(X))

           SET X=""

           IF $GET(REC(130,SRN,118,"I"))="Y"

               Begin DoDot:1

 +2                IF +($GET(REC(130,SRN,122,"I")))>0

                       SET X="(Completed)"

 +3                IF +($GET(REC(130,SRN,121,"I")))>0&(+($GET(REC(130,SRN,122,"I")))'>0)

                       SET X="Incomplete"

 +4                IF X=""

                       SET X="Unknown"

               End DoDot:1

               QUIT X

 +5        IF +($GET(REC(130,SRN,17,"I")))>0

               Begin DoDot:1

 +6                SET X=$SELECT(+($GET(REC(130,SRN,.205,"I")))>0:"(Aborted)",1:"Cancelled")

               End DoDot:1

               QUIT X

 +7        IF +($GET(REC(130,SRN,.23,"I")))>0

               SET X="(Completed)"

               QUIT X

 +8        IF +($GET(REC(130,SRN,.22,"I")))>0

               SET X="Incomplete"

               QUIT X

 +9        IF +($GET(REC(130,SRN,10,"I")))>0

               SET X="Scheduled"

               QUIT X

 +10       IF +($GET(REC(130,SRN,36,"I")))>0

               IF +($GET(REC(130,SRN,.22,"I")))'>0

                   SET X="Requested"

                   QUIT X

 +11       SET X="Unknown"

 +12       QUIT X

SUB       ;

 +1        NEW DA,DR,DIC,DIQ,IENS,FILE,FLD,FLDS,FLDI,FLDA,FLDB,FLDR,FLDRT,SRM,SRC,SRI,SRJ,STXT,SNAM,SCOD,SUB

 +2        IF +SRSG

               Begin DoDot:1

 +3       ;

 +4       ; ^SRF(DO,14,I)                .72  Other Preop Diag    14;0  130.17

 +5       ; $P(^SRF(DO,14,I,0),U)        .01  Other Preop Diag     0;1  Text

 +6       ;

 +7                SET DA=IEN

                   SET (FILE,DIC)=130

                   SET SUB=130.17

                   SET DR=.72

                   SET DR(SUB)=".01"

                   SET DIQ="REC(130,"_IEN_","

                   SET DIQ(0)="IE"

 +8                KILL REC(SUB)

                   SET SRI=0

                   FOR 

                       SET SRI=$ORDER(^SRF(+($GET(IEN)),14,SRI))

                       IF +SRI=0

                           QUIT 

                       Begin DoDot:2

 +9                        SET DA(SUB)=SRI

 +10                       DO EN^DIQ1

 +11                       SET REC(130,IEN,130.17,SRI,.01,"S")=$$EN2^SROGMTS0($GET(REC(130,IEN,130.17,SRI,.01,"E")))

                       End DoDot:2

 +12      ;

 +13      ; ^SRF(DO,15,I)                .74  Other Postop Diags  15;0  130.18

 +14      ; $P(^SRF(DO,15,I,0),U)        .01  Other Postop Diags   0;1  Text

 +15      ;

 +16               SET DA=IEN

                   SET (FILE,DIC)=130

                   SET SUB=130.18

                   SET DR=.74

                   SET DR(SUB)=".01"

                   SET DIQ="REC(130,"_IEN_","

                   SET DIQ(0)="IE"

 +17               KILL REC(SUB)

                   SET SRI=0

                   FOR 

                       SET SRI=$ORDER(^SRF(+($GET(IEN)),15,SRI))

                       IF +SRI=0

                           QUIT 

                       Begin DoDot:2

 +18                       SET DA(SUB)=SRI

 +19                       DO EN^DIQ1

 +20                       SET REC(130,IEN,130.18,SRI,.01,"S")=$$EN2^SROGMTS0($GET(REC(130,IEN,130.18,SRI,.01,"E")))

                       End DoDot:2

               End DoDot:1

 +21      ;

 +22      ; ^SRF(SRN,"OPMOD",I)           28  Pri Pro CPT Mod  OPMOD;0  130.028

 +23      ; $P(^SRF(SRN,"OPMOD",I,0),U)  .01  Pri Pro CPT Mod      0;1  Ptr 81.3

 +24      ;

 +25       IF SRCPTM

               Begin DoDot:1

 +26               SET DA=IEN

                   SET (FILE,DIC)=130

                   SET SUB=130.028

                   SET DR=28

                   SET DR(SUB)=".01"

                   SET DIQ="REC(130,"_IEN_","

                   SET DIQ(0)="IE"

 +27               KILL REC(SUB)

                   SET SRI=0

                   FOR 

                       SET SRI=$ORDER(^SRF(+($GET(IEN)),"OPMOD",SRI))

                       IF +SRI=0

                           QUIT 

                       Begin DoDot:2

 +28                       SET DA(SUB)=SRI

 +29                       DO EN^DIQ1

 +30                       SET SRM=+($GET(REC(130,+($GET(IEN)),SUB,+($GET(SRI)),.01,"I")))

                           IF SRM>0

                               DO MOD(SRM,FILE,SUB)

                       End DoDot:2

               End DoDot:1

 +31      ;

 +32      ; ^SRF(DO,13,I)                .42  Other Proc          13;0  130.16

 +33      ; $P(^SRF(DO,13,I,0),U)        .01  Other Proc           0;1  Text      

 +34      ; $P(^SRF(DO,13,I,2),U)          3  Other Proc CPT Code  2;1  Ptr 81

 +35      ;

 +36       SET DA=IEN

           SET (FILE,DIC)=130

           SET SUB=130.16

           SET DR=.42

           SET DR(SUB)=".01;3"

           SET DIQ="REC(130,"_IEN_","

           SET DIQ(0)="IE"

 +37       KILL REC(SUB)

           SET SRI=0

           FOR 

               SET SRI=$ORDER(^SRF(+($GET(IEN)),13,SRI))

               IF +SRI=0

                   QUIT 

               Begin DoDot:1

 +38               SET DA(SUB)=SRI

 +39               DO EN^DIQ1

                   SET SRM=+($GET(REC(130,IEN,130.16,SRI,3,"I")))

 +40               IF SRM>0

                       SET REC(130,IEN,130.16,SRI,3,"N")=$PIECE($$CPT^ICPTCOD(+SRM,$PIECE($GET(^SRF(IEN,0)),"^",9)),"^",3)

 +41               NEW SRT,SRS,SRC

                   SET SRM=$GET(REC(130,IEN,130.16,SRI,3,"I"))

                   IF SRM>0

                       Begin DoDot:2

 +42                       SET SRC=$$CPT^ICPTCOD(SRM,$PIECE($GET(^SRF(IEN,0)),"^",9))

                           SET (SRCS,SRS)=$$EN2^SROGMTS0($PIECE(SRC,"^",3))

 +43                       SET REC(130,IEN,130.16,SRI,3,"X")=$PIECE(SRC,"^",2)_"^"_$PIECE(SRC,"^",3)

 +44                       SET SRC=$PIECE(SRC,"^",2)

 +45                       SET SRT=$$EN2^SROGMTS0($GET(REC(130,IEN,130.16,SRI,.01,"E")))

 +46                       IF $LENGTH(SRS)&(SRS'=SRT)

                               SET SRT=SRT_" - "_$$EN2^SROGMTS0(SRS)

 +47                       IF $LENGTH(SRC)=5

                               SET SRT=SRT_" (CPT "_SRC_")"

                               SET SRCS=SRCS_" (CPT "_SRC_")"

 +48                       SET REC(130,IEN,130.16,SRI,3,"N")=SRS

 +49                       SET REC(130,IEN,130.16,SRI,.01,"S")=SRT

 +50                       SET REC(130,IEN,130.16,SRI,3,"S")=SRCS