Routine: SR182UTL

SR182UTL ;BIR/SJA - SR*3*182 UTILITY ROUTINE ;11/21/2013

 ;;3.0;Surgery;**182**;24 Jun 93;Build 49

PRE ; pre-install process for SR*3*182

 ; delete data from file #136.5 and re-initialize file

 K ^SRO(136.5) S ^SRO(136.5,0)="PERIOPERATIVE OCCURRENCE CATEGORY^136.5I^^"

 ; delete DD for modified field #.69

 F DA=.69,74 S DIK="^DD(130,",DA(1)=130 D ^DIK K DA,DIK

POST ; post-install process for SR*3*182

 N SRI,SRTXT,SRIEN,SRZ,SREF,SRX,SRY,X

 D MES^XPDUTL("  Starting post-install of SR*3.0*182")

 ; inactivate existing cancellation reasons and add new ones

 S SRZ=0 F  S SRZ=$O(^SRO(135,SRZ)) Q:'SRZ!(SRZ>1009)  S DIE=135,DA=SRZ,DR="10////1" D ^DIE K DA,DIE,DR

 ; kill then rebuild "B","C" x-ref:

 K ^SRO(135,"B"),^SRO(135,"C")

 F SRI=1:1 S SRX=$P($T(TXTCAN+SRI),";;",2) Q:SRX="EOM"  S SRTXT=$P(SRX,"^",2) D

 .S SRIEN=1009+SRI I '$D(^SRO(135,SRIEN,0)) S ^SRO(135,SRIEN,0)=SRTXT_"^"_SRI

 F SREF=".01^B","1^C" S DIK="^SRO(135,",DIK(1)=SREF D ENALL^DIK

 D MES^XPDUTL("The Surgery Cancellation Reason file (#135) has been updated")

 I '$$PATCH^XPDUTL("SR*3.0*182") D ADDIS

 ; CPT EXCLUSIONS file #137

 D MES^XPDUTL("  Populating CPT EXCLUSIONS file...")

 K ^SRO(137)

 S ^SRO(137,0)="CPT EXCLUSIONS^137P^^"

 D PEX^SR182UT0,PEX^SR182UT1,PEX^SR182UT2,PEX^SR182UT3

DEL ; delete routines SR182UT0, SR182UT1, SR182UT2, and SR182UT3

 F X="SR182UT0","SR182UT1","SR182UT2","SR182UT3" X ^%ZOSF("TEST") I $T D

 .D MES^XPDUTL(" Deleting routine "_X_"...")

 .X ^%ZOSF("DEL")

 K DA,DIC,DD,DO,DINUM,X

INT S SRY=0,SRY=$O(^ICPT("B",SRX,SRY)) Q:SRY=""

 K DA,DIC,DD,DO,DINUM S (DINUM,X)=SRY,DIC="^SRO(137,",DIC(0)="L" D FILE^DICN

ADDIS ; inactivate existing SURGERY DISPOSITION file (#131.6) entries and add new ones

 S SRZ=0 F  S SRZ=$O(^SRO(131.6,SRZ)) Q:'SRZ  S DIE=131.6,DA=SRZ,DR="2////1" D ^DIE K DA,DIE,DR

 ; kill and then rebuild "B","C","D" x-ref:

 K ^SRO(131.6,"B"),^SRO(131.6,"C"),^SRO(131.6,"D")

 S SRMAX=$O(^SRO(131.6," "),-1) F SRI=1:1 S SRX=$P($T(TXTDIS+SRI),";;",2) Q:SRX="EOM"  D

 .S SRIEN=SRMAX+SRI I '$D(^SRO(131.6,SRIEN,0)) S ^SRO(131.6,SRIEN,0)=$P(SRX,"^",2)_"^"_$P(SRX,"^")

 F SREF=".01^B","1^C" S DIK="^SRO(131.6,",DIK(1)=SREF D ENALL^DIK

 K DIK S ^DD(131.6,.01,7.5)="I $G(DIC(0))[""L"",'$D(XUMF) K X D EN^DDIOL(""File is locked. No new entries or edits are allowed."","""",""!?5,$C(7)"")"

 D MES^XPDUTL("The Surgery Disposition file (#131.6) has been updated")

TXTCAN ; new surgery cancellation reasons

 ;;1^PATIENT RELATED ISSUE

 ;;2^ENVIRONMENTAL ISSUE

 ;;3^STAFF ISSUE

 ;;4^PATIENT HEALTH STATUS

 ;;5^CLIN URGENT/EMERGENT CASE

 ;;6^SCHED ISSUES NON EMERGENT CASE

 ;;7^UNAVAILABLE BED

 ;;8^UNAVAILABLE EQUIP EXCLUDE RME

 ;;9^UNAVAILABLE REUSABLE EQUP-RME

 ;;10^CASE MOVED TO EARLIER DATE

 ;;EOM

TXTDIS ; new surgery disposition entries

 ;;O^OUTPATIENT/DISCHARGE

 ;;I^ICU

 ;;S^STEPDOWN

 ;;W^WARD

 ;;OBS^OBSERVATION UNIT

 ;;M^MORGUE

 ;;EOM

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSR182UTL   2937     printed  Mar 13, 2025@21:43:27                                                                                                                                                                                                    Page 2

SR182UTL  ;BIR/SJA - SR*3*182 UTILITY ROUTINE ;11/21/2013

 +1       ;;3.0;Surgery;**182**;24 Jun 93;Build 49

 +2        QUIT

PRE       ; pre-install process for SR*3*182

 +1       ; delete data from file #136.5 and re-initialize file

 +2        KILL ^SRO(136.5)

           SET ^SRO(136.5,0)="PERIOPERATIVE OCCURRENCE CATEGORY^136.5I^^"

 +3       ; delete DD for modified field #.69

 +4        FOR DA=.69,74

               SET DIK="^DD(130,"

               SET DA(1)=130

               DO ^DIK

               KILL DA,DIK

 +5        QUIT

POST      ; post-install process for SR*3*182

 +1        NEW SRI,SRTXT,SRIEN,SRZ,SREF,SRX,SRY,X

 +2        DO MES^XPDUTL("  Starting post-install of SR*3.0*182")

 +3       ;

 +4       ; inactivate existing cancellation reasons and add new ones

 +5        SET SRZ=0

FOR

               SET SRZ=$ORDER(^SRO(135,SRZ))

               if 'SRZ!(SRZ>1009)

                   QUIT

               SET DIE=135

               SET DA=SRZ

               SET DR="10////1"

               DO ^DIE

               KILL DA,DIE,DR

 +6       ; kill then rebuild "B","C" x-ref:

 +7        KILL ^SRO(135,"B"),^SRO(135,"C")

 +8        FOR SRI=1:1

               SET SRX=$PIECE($TEXT(TXTCAN+SRI),";;",2)

               if SRX="EOM"

                   QUIT

               SET SRTXT=$PIECE(SRX,"^",2)

               Begin DoDot:1

 +9                SET SRIEN=1009+SRI

                   IF '$DATA(^SRO(135,SRIEN,0))

                       SET ^SRO(135,SRIEN,0)=SRTXT_"^"_SRI

               End DoDot:1

 +10       FOR SREF=".01^B","1^C"

               SET DIK="^SRO(135,"

               SET DIK(1)=SREF

               DO ENALL^DIK

 +11       DO MES^XPDUTL("The Surgery Cancellation Reason file (#135) has been updated")

 +12      ;

 +13       IF '$$PATCH^XPDUTL("SR*3.0*182")

               DO ADDIS

 +14      ;

 +15      ; CPT EXCLUSIONS file #137

 +16       DO MES^XPDUTL("  Populating CPT EXCLUSIONS file...")

 +17       KILL ^SRO(137)

 +18       SET ^SRO(137,0)="CPT EXCLUSIONS^137P^^"

 +19       DO PEX^SR182UT0

           DO PEX^SR182UT1

           DO PEX^SR182UT2

           DO PEX^SR182UT3

 +20      ;

DEL       ; delete routines SR182UT0, SR182UT1, SR182UT2, and SR182UT3

 +1        FOR X="SR182UT0","SR182UT1","SR182UT2","SR182UT3"

               XECUTE ^%ZOSF("TEST")

               IF $TEST

                   Begin DoDot:1

 +2                    DO MES^XPDUTL(" Deleting routine "_X_"...")

 +3                    XECUTE ^%ZOSF("DEL")

                   End DoDot:1

 +4        KILL DA,DIC,DD,DO,DINUM,X

 +5        QUIT

INT        SET SRY=0

           SET SRY=$ORDER(^ICPT("B",SRX,SRY))

           if SRY=""

               QUIT

 +1        KILL DA,DIC,DD,DO,DINUM

           SET (DINUM,X)=SRY

           SET DIC="^SRO(137,"

           SET DIC(0)="L"

           DO FILE^DICN

 +2        QUIT

ADDIS     ; inactivate existing SURGERY DISPOSITION file (#131.6) entries and add new ones

 +1        SET SRZ=0

FOR

               SET SRZ=$ORDER(^SRO(131.6,SRZ))

               if 'SRZ

                   QUIT

               SET DIE=131.6

               SET DA=SRZ

               SET DR="2////1"

               DO ^DIE

               KILL DA,DIE,DR

 +2       ; kill and then rebuild "B","C","D" x-ref:

 +3        KILL ^SRO(131.6,"B"),^SRO(131.6,"C"),^SRO(131.6,"D")

 +4        SET SRMAX=$ORDER(^SRO(131.6," "),-1)

           FOR SRI=1:1

               SET SRX=$PIECE($TEXT(TXTDIS+SRI),";;",2)

               if SRX="EOM"

                   QUIT

               Begin DoDot:1

 +5                SET SRIEN=SRMAX+SRI

                   IF '$DATA(^SRO(131.6,SRIEN,0))

                       SET ^SRO(131.6,SRIEN,0)=$PIECE(SRX,"^",2)_"^"_$PIECE(SRX,"^")

               End DoDot:1

 +6        FOR SREF=".01^B","1^C"

               SET DIK="^SRO(131.6,"

               SET DIK(1)=SREF

               DO ENALL^DIK

 +7        KILL DIK

           SET ^DD(131.6,.01,7.5)="I $G(DIC(0))[""L"",'$D(XUMF) K X D EN^DDIOL(""File is locked. No new entries or edits are allowed."","""",""!?5,$C(7)"")"

 +8        DO MES^XPDUTL("The Surgery Disposition file (#131.6) has been updated")

 +9        QUIT

TXTCAN    ; new surgery cancellation reasons

 +1       ;;1^PATIENT RELATED ISSUE

 +2       ;;2^ENVIRONMENTAL ISSUE

 +3       ;;3^STAFF ISSUE

 +4       ;;4^PATIENT HEALTH STATUS

 +5       ;;5^CLIN URGENT/EMERGENT CASE

 +6       ;;6^SCHED ISSUES NON EMERGENT CASE

 +7       ;;7^UNAVAILABLE BED

 +8       ;;8^UNAVAILABLE EQUIP EXCLUDE RME

 +9       ;;9^UNAVAILABLE REUSABLE EQUP-RME

 +10      ;;10^CASE MOVED TO EARLIER DATE

 +11      ;;EOM

TXTDIS    ; new surgery disposition entries

 +1       ;;O^OUTPATIENT/DISCHARGE

 +2       ;;I^ICU

 +3       ;;S^STEPDOWN

 +4       ;;W^WARD

 +5       ;;OBS^OBSERVATION UNIT

 +6       ;;M^MORGUE

 +7       ;;EOM

SR182UTL.m