| 1 | DG53729P ;ALB/JRC - Add NURSING HOME TREATING SPECIALTIES ; 3/12/07 7:21am
|
---|
| 2 | ;;5.3;Registration;**729**;Aug 13, 1993;Build 59
|
---|
| 3 | ;base program: DG53683P
|
---|
| 4 | EN ;Add Treating Specialties to the SPECIALITY file (#42.4)
|
---|
| 5 | N DGI,DGERR,DGSPEC,DGIFN,DGQUES
|
---|
| 6 | S DGIFN=0
|
---|
| 7 | ;add new treating specialties
|
---|
| 8 | F DGI=1:1 S DGSPEC=$P($T(TRSP+DGI),";;",2) Q:DGSPEC="QUIT" D
|
---|
| 9 | .D TSPEC
|
---|
| 10 | .S DGQUES=$P(DGSPEC,U,9)
|
---|
| 11 | .D FAC
|
---|
| 12 | .Q
|
---|
| 13 | ;edit existing treating specialties
|
---|
| 14 | D EDIT
|
---|
| 15 | ;inactivate existing treating specialties
|
---|
| 16 | D INACT
|
---|
| 17 | ;edit existing surgical specialties
|
---|
| 18 | D EDIT^DG53729R
|
---|
| 19 | ;move ptf code (those < 100) into new austin ptf code field
|
---|
| 20 | D APTFC
|
---|
| 21 | ;place option out of order and remove from menu
|
---|
| 22 | D MENU
|
---|
| 23 | ;inactivate existing ptf expanded code categories
|
---|
| 24 | D PTFCAT^DG53729R
|
---|
| 25 | ;Update 9/30/2007 Census close out date, if exists
|
---|
| 26 | D EN^DG53729C
|
---|
| 27 | Q
|
---|
| 28 | TSPEC ;Add treating specialty to SPECIALTY File (#42.4)
|
---|
| 29 | D BMES^XPDUTL(">>>"_$P(DGSPEC,U,2)_">>>")
|
---|
| 30 | N DA,DGFILE,DGMULT,DIC,DIE,DGDA1,DINUM,DLAYGO,DR,X,Y
|
---|
| 31 | S DGERR=0
|
---|
| 32 | S DIC="^DIC(42.4,"
|
---|
| 33 | S DIC(0)="LX"
|
---|
| 34 | S DINUM=$P(DGSPEC,U)
|
---|
| 35 | S X=$P(DGSPEC,U,2)
|
---|
| 36 | S DLAYGO=42.4
|
---|
| 37 | D ^DIC
|
---|
| 38 | S (DGIFN,DGDA1)=Y
|
---|
| 39 | I +DGIFN=-1 D Q
|
---|
| 40 | .D MES^XPDUTL(" Entry not added to SPECIALTY File (#42.4). No further updating will occur.")
|
---|
| 41 | .D MES^XPDUTL(" Please contact Customer Service for assistance.")
|
---|
| 42 | .Q
|
---|
| 43 | I $P(DGIFN,U,3)'=1&(+DGIFN'=$P(DGSPEC,U)) D Q
|
---|
| 44 | .D MES^XPDUTL(" Entry exists in SPECIALTY File (#42.4), but with a different PTF Code #.")
|
---|
| 45 | .D MES^XPDUTL(" No further updating will occur. Please review entry.")
|
---|
| 46 | .S DGERR=1
|
---|
| 47 | .Q
|
---|
| 48 | D MES^XPDUTL(" Entry "_$S($P(DGIFN,U,3)=1:"added to",1:"exists in")_" SPECIALTY File (#42.4).")
|
---|
| 49 | D MES^XPDUTL(" Updating SPECIALTY File fields.")
|
---|
| 50 | S DIE=DIC
|
---|
| 51 | S DR="1///"_$P(DGSPEC,U,3)_";3///"_$P(DGSPEC,U,4)_";4///"_$P(DGSPEC,U,5)_";5///"_$P(DGSPEC,U,6)_";6///"_$P(DGSPEC,U,7)_";7///"_$P(DGSPEC,U,10)
|
---|
| 52 | S DA=+DGIFN
|
---|
| 53 | D ^DIE
|
---|
| 54 | S DGFILE=42.4
|
---|
| 55 | S DGMULT=10
|
---|
| 56 | S DIC="^DIC(42.4,"_+DGIFN_",""E"","
|
---|
| 57 | D MULT
|
---|
| 58 | Q
|
---|
| 59 | FAC ;Add treating specialty to Facility Treating Specialty file (#45.7)
|
---|
| 60 | N DA,DGFILE,DGMULT,DIC,DIE,DLAYGO,DR,X,Y
|
---|
| 61 | S DIC="^DIC(45.7,"
|
---|
| 62 | S DIC(0)="LXZ"
|
---|
| 63 | S DLAYGO=45.7
|
---|
| 64 | S X=$P(DGSPEC,U,2)
|
---|
| 65 | D ^DIC
|
---|
| 66 | S DGDA1=Y
|
---|
| 67 | I +DGDA1=-1 D BMES^XPDUTL(" Entry not added to FACILITY TREATING SPECIALTY File(#45.7).") Q
|
---|
| 68 | I $P(DGDA1,U,3)'=1&($P(Y(0),U,2)'=$P(DGSPEC,U)) D Q
|
---|
| 69 | .D BMES^XPDUTL(" Entry exists in FACILITY TREATING SPECIALTY File (#45.7), but with")
|
---|
| 70 | .D MES^XPDUTL(" a different PTF Code #. No further updating will occur.")
|
---|
| 71 | .D MES^XPDUTL(" Please review entry.")
|
---|
| 72 | .Q
|
---|
| 73 | D BMES^XPDUTL(" Entry "_$S($P(DGDA1,U,3)=1:"added to",1:"exists in")_" FACILITY TREATING SPECIALTY File (#45.7).")
|
---|
| 74 | D MES^XPDUTL(" Updating SPECIALTY field...")
|
---|
| 75 | S DIE=DIC
|
---|
| 76 | S DA=+DGDA1
|
---|
| 77 | S DR="1////"_$P(DGSPEC,U)
|
---|
| 78 | D ^DIE
|
---|
| 79 | S DGFILE=45.7
|
---|
| 80 | S DGMULT=100
|
---|
| 81 | S DIC="^DIC(45.7,"_+DGDA1_",""E"","
|
---|
| 82 | D MULT
|
---|
| 83 | Q
|
---|
| 84 | MULT ;Add Effective Date
|
---|
| 85 | N DA,DIE,DR
|
---|
| 86 | S DA(1)=+DGDA1
|
---|
| 87 | S DIC(0)="LX"
|
---|
| 88 | S DIC("P")=$P(^DD(DGFILE,DGMULT,0),"^",2)
|
---|
| 89 | S X=3071001
|
---|
| 90 | D ^DIC
|
---|
| 91 | S DA=+Y
|
---|
| 92 | I +Y=-1 D MES^XPDUTL(" Effective date not added.") Q
|
---|
| 93 | D MES^XPDUTL(" Effective date added.")
|
---|
| 94 | S DIE=DIC
|
---|
| 95 | S DR=".02///Y"
|
---|
| 96 | D ^DIE
|
---|
| 97 | Q
|
---|
| 98 | INACT ;inactivate treating specialties
|
---|
| 99 | N DA,DIE,DR,X,DGTSP
|
---|
| 100 | F DGTSP=1,7,34 D
|
---|
| 101 | . S DIC="^DIC(42.4,"_DGTSP_",""E"","
|
---|
| 102 | . S DA(1)=DGTSP
|
---|
| 103 | . S DIC(0)="LX"
|
---|
| 104 | . S DIC("P")=$P(^DD(42.4,10,0),"^",2)
|
---|
| 105 | . S X=3071001
|
---|
| 106 | . D ^DIC
|
---|
| 107 | . S DA=+Y
|
---|
| 108 | . I +Y=-1 D BMES^XPDUTL(">>>Inactive date not added to TS code "_DGTSP_" in the Specialty file.<<<") Q
|
---|
| 109 | . D BMES^XPDUTL(">>>Inactive date added to TS code "_DGTSP_" in the Specialty file.<<<")
|
---|
| 110 | . S DIE=DIC
|
---|
| 111 | . S DR=".02///N"
|
---|
| 112 | . D ^DIE
|
---|
| 113 | . ;check for CODES in the Facility Treating Specialty File (45.7
|
---|
| 114 | . ;add inactivation date of 7/1/2006
|
---|
| 115 | . D BMES^XPDUTL(" ")
|
---|
| 116 | . D MES^XPDUTL(" FACILITY TREATING SPECIALTY FILE being checked to see if any entries are")
|
---|
| 117 | . D MES^XPDUTL(" pointing to "_DGTSP_". If so, they will be inactivated.>>>")
|
---|
| 118 | .N DAA F DAA=0:0 S DAA=$O(^DIC(45.7,"ASPEC",DGTSP,DAA)) Q:'DAA D
|
---|
| 119 | .. N DIE,DR,TS,X S TS=""
|
---|
| 120 | ..S TS=$P($G(^DIC(45.7,DAA,0)),"^")
|
---|
| 121 | ..S DIC="^DIC(45.7,"_DAA_",""E"","
|
---|
| 122 | ..S DA(1)=DAA
|
---|
| 123 | ..S DIC(0)="LX"
|
---|
| 124 | ..S X=3060701
|
---|
| 125 | ..D ^DIC
|
---|
| 126 | ..S DA=+Y
|
---|
| 127 | ..I +Y=-1 D BMES^XPDUTL(" Inactive date not added to "_TS_"in the Facility Treating Specialty file.") Q
|
---|
| 128 | ..D BMES^XPDUTL(" Inactive date added to "_TS_" in the Facility Treating Specialty file.<<<")
|
---|
| 129 | ..S DIE=DIC
|
---|
| 130 | ..S DR=".02///N"
|
---|
| 131 | ..D ^DIE
|
---|
| 132 | Q
|
---|
| 133 | EDIT ;Edit treating specialties
|
---|
| 134 | ;
|
---|
| 135 | N DS,DIE,DR,DGI
|
---|
| 136 | S DIE="^DIC(42.4,"
|
---|
| 137 | S DIC(0)="LX"
|
---|
| 138 | F DGI=1:1 S DGSPEC=$P($T(ETRSP+DGI),";;",2) Q:DGSPEC="QUIT" D
|
---|
| 139 | . S DGERR=0
|
---|
| 140 | . S DA=$P(DGSPEC,U)
|
---|
| 141 | . S DR=".01///"_$P(DGSPEC,U,2)_";1///"_$P(DGSPEC,U,3)_";3///"_$P(DGSPEC,U,4)_";4///"_$P(DGSPEC,U,5)_";5///"_$P(DGSPEC,U,6)_";6///"_$P(DGSPEC,U,7)
|
---|
| 142 | . D ^DIE
|
---|
| 143 | . D BMES^XPDUTL(" ")
|
---|
| 144 | . D BMES^XPDUTL(" ")
|
---|
| 145 | . D BMES^XPDUTL(">>>"_$P(DGSPEC,U)_" code updated to "_$P(DGSPEC,U,2)_" in the Specialty file.>>>")
|
---|
| 146 | N DS,DIE,DR,DGI,DGII,DGSP,CNT,DGSPEC,DGSPEC1
|
---|
| 147 | S DIE="^DIC(45.7,"
|
---|
| 148 | S DIC(0)="LX"
|
---|
| 149 | F DGI=1:1 S DGSPEC=$P($T(ETRSP+DGI),";;",2) Q:DGSPEC="QUIT" D
|
---|
| 150 | . S DGERR=0
|
---|
| 151 | . S DGSP=$P(DGSPEC,U)
|
---|
| 152 | . S CNT=0,DGSPEC1=0 F DGII=0:0 S DGSPEC1=$O(^DIC(45.7,"ASPEC",DGSP,DGSPEC1)) Q:'DGSPEC1 S CNT=CNT+1 D
|
---|
| 153 | .. I CNT=1 D
|
---|
| 154 | ... I $$ACTIVE^DGACT(45.7,DGSPEC1)'=1 S CNT=0 Q
|
---|
| 155 | ... S DA=DGSPEC1,DR=".01///"_$P(DGSPEC,U,2)_";99///@"
|
---|
| 156 | ... D BMES^XPDUTL(" "_$P(^DIC(45.7,DGSPEC1,0),U)_" name has been changed to "_$P(DGSPEC,U,2)_" in the Facility Treating Specialty file.")
|
---|
| 157 | ... D ^DIE
|
---|
| 158 | .. E D
|
---|
| 159 | ... S TS=""
|
---|
| 160 | ... S TS=$P($G(^DIC(45.7,DGSPEC1,0)),"^")
|
---|
| 161 | ... D BMES^XPDUTL(" Please review Facility Treating Specialty "_TS_". The entry name may need changing or entry may need inactivating since more than one entry points to "_$P(DGSPEC,U,2)_" in the Specialty file.<<<")
|
---|
| 162 | Q
|
---|
| 163 | TRSP ;PTF code^Specialty^Print Name^Service^Ask Psych^Billing Bedsection^CDR^^Ques#^Austin PTF Code
|
---|
| 164 | ;;13^CARDIAC INTENSIVE CARE UNIT^^MEDICINE^N^GENERAL MEDICAL CARE^1117^^^13
|
---|
| 165 | ;;30^PEDIATRICS^^MEDICINE^N^GENERAL MEDICAL CARE^1110^^^30
|
---|
| 166 | ;;48^CARDIAC SURGERY^^SURGERY^N^SURGICAL CARE^1210^^^48
|
---|
| 167 | ;;49^TRANSPLANTATION^^SURGERY^N^SURGICAL CARE^1210^^^49
|
---|
| 168 | ;;78^ANESTHESIOLOGY^^SURGERY^N^SURGICAL CARE^1210^^^78
|
---|
| 169 | ;;82^PM&R TRANSITIONAL REHAB^^REHAB MEDICINE^N^REHABILITATION MEDICINE^1113^^^82
|
---|
| 170 | ;;97^SURGICAL STEPDOWN^^SURGERY^N^SURGICAL CARE^1210^^^97
|
---|
| 171 | ;;100^SHORT STAY GRECC-NHCU^SS GRECC-NHCU^NHCU^N^NURSING HOME CARE^1430^^^1A
|
---|
| 172 | ;;101^LONG STAY GRECC-NHCU^LS GRECC-NHCU^NHCU^N^NURSING HOME CARE^1410^^^1B
|
---|
| 173 | ;;102^SHORT STAY GRECC-GEM-NHCU^SS GRECC-GEM-NH^NHCU^N^NURSING HOME CARE^1420^^^1C
|
---|
| 174 | ;;103^GRECC-GEM-REHAB^^REHAB MEDICINE^N^REHABILITATION MEDICINE^1120^^^1D
|
---|
| 175 | ;;104^GRECC-MED^^MEDICINE^N^GENERAL MEDICAL CARE^1110^^^1E
|
---|
| 176 | ;;QUIT
|
---|
| 177 | ETRSP ;;PTF code^Specialty^Print Name^Service^Ask Psych^Billing Bedsection^CDR
|
---|
| 178 | ;;12^MEDICAL ICU^^MEDICINE^N^GENERAL MEDICAL CARE^1117^^
|
---|
| 179 | ;;50^GENERAL SURGERY^^SURGERY^N^SURGICAL CARE^1210^^
|
---|
| 180 | ;;51^OB/GYN^^SURGERY^N^SURGICAL CARE^1210^^
|
---|
| 181 | ;;55^EAR, NOSE, THROAT (ENT)^^SURGERY^N^SURGICAL CARE^1210^^
|
---|
| 182 | ;;56^PLASTIC SURGERY^^SURGERY^N^SURGICAL CARE^1210^^
|
---|
| 183 | ;;58^THORACIC SURGERY^^SURGERY^N^SURGICAL CARE^1210^^
|
---|
| 184 | ;;60^ORAL SURGERY^^SURGERY^N^SURGICAL CARE^1210^^
|
---|
| 185 | ;;QUIT
|
---|
| 186 | Q
|
---|
| 187 | MENU ;Remove option from menu and place out of order
|
---|
| 188 | N MENU,OPTION,CHECK,IEN
|
---|
| 189 | S MENU="DGPT TOOLS MENU",OPTION="DG PTF SUFFIX EFF DATE EDIT"
|
---|
| 190 | S CHECK=$$DELETE^XPDMENU(MENU,OPTION)
|
---|
| 191 | D BMES^XPDUTL(">>> "_OPTION_" OPTION "_$S(CHECK:"REMOVED FROM ",1:"DOES NOT EXIST IN ")_MENU_" <<<")
|
---|
| 192 | D OUT^XPDMENU(OPTION,"OUT OF ORDER, DO NOT USE THIS OPTION!!!")
|
---|
| 193 | D BMES^XPDUTL(">>> "_OPTION_" OPTION PLACED OUT ORDER <<<")
|
---|
| 194 | ;Rename CDR Inquiry [DGPT CDR INQUIRY] menu
|
---|
| 195 | D BMES^XPDUTL(">>> Renaming CDR Inquiry option to MPCR Inquiry <<<")
|
---|
| 196 | S IEN=$$LKOPT^XPDMENU("DGPT CDR INQUIRY")
|
---|
| 197 | I 'IEN D Q
|
---|
| 198 | .D BMES^XPDUTL(">>> Was not able to locate CDR Inquiry option <<<")
|
---|
| 199 | .D BMES^XPDUTL(">>> PLEASE CONTACT THE NATIONAL HELP DESK <<<")
|
---|
| 200 | S DIE="^DIC(19,",DIC(0)="LX"
|
---|
| 201 | S DA=IEN,DR="1///"_"MPCR INQUIRY"_";1.1///"_"MPCR INQUIRY" D ^DIE
|
---|
| 202 | S ^DIC(19,IEN,1,1,0)="This option allows the user to view the MPCR information related"
|
---|
| 203 | S ^DIC(19,IEN,1,3,0)="as the data shown on the 'MPCR' screen of the 'Load/Edit PTF Record'"
|
---|
| 204 | D RENAME^XPDMENU("DGPT CDR INQUIRY","DGPT MPCR INQUIRY")
|
---|
| 205 | D BMES^XPDUTL(">>> CDR Inquiry Menu option Succesfully renamed <<<")
|
---|
| 206 | Q
|
---|
| 207 | APTFC ;move ptf code (those < 100) into new austin ptf code field
|
---|
| 208 | N DGX,DGENTRY,DA,DR,DIE
|
---|
| 209 | D BMES^XPDUTL(">>> Populating PTF CODE field (#7) of the SPECIALTY (#42.4) file")
|
---|
| 210 | S DGX="" F S DGX=$O(^DIC(42.4,"B",DGX)) Q:DGX="" D
|
---|
| 211 | . S DGENTRY=$O(^DIC(42.4,"B",DGX,0)) I DGENTRY D
|
---|
| 212 | .. Q:$L(DGENTRY)>2 I ($E(DGENTRY,1)?1A)!($E(DGENTRY,2)?1A) Q
|
---|
| 213 | .. S DA=DGENTRY,DR="7///"_DGENTRY,DIE="^DIC(42.4," D ^DIE
|
---|
| 214 | Q
|
---|