Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: AUTPOS1

AUTPOS1.m

Go to the documentation of this file. 
  1. AUTPOS1 ; IHS/DIRM/JDM/DFM - POST INIT; [ 03/04/98   8:10 AM ]
  1.  ;;98.1;IHS DICTIONARIES (POINTERS);;MAR 04, 1998;Build 6
  1.  ;
  1.  ;
  1. UPDATE ;EP - update fields in AUT dictionaries
  1.  D ^XBKVAR
  1.  I DUZ(0)'="@" W !!,"SORRY, YOU MUST HAVE PROGRAMMER ACCESS (Variable DUZ(0) must = '@'.)",!,"POST INITS NOT RUN - PLEASE DO SO LATER BY RUNNING RTN '^AUTPOS1' (D ^AUTPOS1)." Q
  1.  W !!,"Many AUT tables will now be updated.  This will take a while.",!
  1.  W !,"Please have your aux port printer turned ON.  THANKS."
  1.  S DIR(0)="Y",DIR("A")="Do you wish to continue",DIR("B")="Y" K DA D ^DIR K DIR
  1.  Q:$D(DIRUT)
  1.  I 'Y W !!,"BYE - POST INIT NOT RUN - PLEASE RUN IT LATER BY RUNNING ^AUTPOS1." Q
  1.  D MEAS
  1.  D MEASTYPE
  1.  D RCAT
  1.  D RECODE^AUTPOS2 ;update recode apc/icd file
  1.  D RECINJ ; update recode injury file
  1.  D REINDEX1 ;reindex AD on 9999999.08 and C on 9999999.12
  1.  D IMM ;update immunization entries with CPT codes
  1.  D EXAM ;update exam table
  1.  D SKINTEST
  1.  D HF
  1.  D PPT ;do presentation types
  1.  D EOJ
  1.  Q
  1. EOJ ;
  1.  K AUTCPT,AUTJ,AUTMOD,AUTT,AUTTXT,AUTVAL,AUTX,AUTY
  1.  K DIC,DD,DLAYGO,DR,DLAYGO,X,Y,D,DIU
  1.  D ^XBFMK
  1.  W !!,"All done with AUTT post init.",!
  1.  Q
  1. REINDEX1 ;
  1.  W !,"Re-indexing a new index on RECODE INJURY"
  1.  S DIK="^AUTTINJ(",DIK(1)=".04^C" D ENALL^DIK
  1.  W !,"Re-indexing a new index on RECODE APC/ICD"
  1.  S DIK="^AUTTRCD(",DIK(1)=".06^AC" D ENALL^DIK
  1.  Q
  1. IMM ;add cpt codes to immunization entries
  1.  W !,"Adding CPT codes to immunization table."
  1.  S AUTT="IMMCPT" F AUTJ=1:1 S AUTX=$T(@AUTT+AUTJ),AUTVAL=$P(AUTX,";;",2) Q:AUTVAL="QUIT"!(AUTVAL="")  D
  1.  .S AUTY=0 F  S AUTY=$O(^AUTTIMM("C",AUTVAL,AUTY)) Q:AUTY'=+AUTY  D
  1.  ..S DA=AUTY,DIE="^AUTTIMM(",DR=".11///"_$P(AUTX,";;",3) D ^DIE I $D(Y) W !,"updating immunization ",AUTVAL,"failed. Notify database mgr. of incomplete Immunization file.."
  1.  ..Q
  1.  .Q
  1.  Q
  1. MEAS ;add cpt code to tonometry measurement type
  1.  W !,"Adding CPT code to measurement types."
  1.  S DA=$O(^AUTTMSR("B","TON",0)) I 'DA W !,"Could not find Tonometry measurement type.  Skipping Tonometry Measurement update." Q
  1.  S DIE="^AUTTMSR(",DR=".11///92100" D ^DIE I $D(Y) W !,"Could not enter CPT code in tonometry file. Notify database mgr." Q
  1.  Q
  1. MEASTYPE ;
  1.  W !,"Adding Measurement Types (Edema and Presentation)",!
  1.  S X="ED",DIC="^AUTTMSR(",DIC(0)="L",DLAYGO=9999999.07,DIC("DR")=".02////EDEMA;.03////55" D ^DIC K DIC,DD,DLAYGO,DA,D0
  1.  S X="PR",DIC="^AUTTMSR(",DIC(0)="L",DLAYGO=9999999.07,DIC("DR")=".02////PRESENTATION;.03////56" D ^DIC K DIC,DD,DLAYGO,DA,D0
  1.  S DA=$O(^AUTTMSR("B","EFF",0)) I DA S DIE="^AUTTMSR(",DR=".01///EF" D ^DIE
  1.  S DA=$O(^AUTTMSR("B","STN",0)) I DA S DIE="^AUTTMSR(",DR=".01///SN" D ^DIE
  1.  S X="CXD",DIC="^AUTTMSR(",DIC(0)="L",DLAYGO=9999999.07,DIC("DR")=".02////CERVIX DILATATION;.03////57" D ^DIC K DIC,DD,DLAYGO,DA,D0
  1.  S X="EF",DIC="^AUTTMSR(",DIC(0)="L",DLAYGO=9999999.07,DIC("DR")=".02////EFACEMENT;.03////58" D ^DIC K DIC,DD,DLAYGO,DA,D0
  1.  S X="SN",DIC="^AUTTMSR(",DIC(0)="L",DLAYGO=9999999.07,DIC("DR")=".02////STATION (PREGNANCY);.03////59" D ^DIC K DIC,DD,DLAYGO,DA,D0
  1.  Q
  1. HF ;
  1.  W !,"Adding a few new health factors"
  1.  ;add current smoker & smokeless
  1.  ;exposure to environmental tobacco smoke
  1.  ;smoker in home
  1.  S X="CURRENT SMOKER & SMOKELESS",DIC="^AUTTHF(",DIC(0)="L",DLAYGO=9999999.64 D ^DIC K DIC,DD,DLAYGO,DA,D0
  1.  S X="EXPOSURE TO ENVIRONMENTAL TOBACCO SMOKE",DIC="^AUTTHF(",DIC(0)="L",DLAYGO=9999999.64 D ^DIC K DIC,DD,DLAYGO,DA,D0
  1.  S X="SMOKER IN HOME",DIC="^AUTTHF(",DIC(0)="L",DLAYGO=9999999.64 D ^DIC K DIC,DD,DLAYGO,DA,D0
  1.  Q
  1. SKINTEST ;
  1.  W !,"Adding CPT code to skin test entries."
  1.  S AUTT="SKCPT" F AUTJ=1:1 S AUTX=$T(@AUTT+AUTJ),AUTVAL=$P(AUTX,";;",2) Q:AUTVAL="QUIT"!(AUTVAL="")  D
  1.  .S AUTY=0 F  S AUTY=$O(^AUTTSK("C",AUTVAL,AUTY)) Q:AUTY'=+AUTY  D
  1.  ..S DA=AUTY,DIE="^AUTTSK(",DR=".11///"_$P(AUTX,";;",3) D ^DIE I $D(Y) W !,"updating skin test code ",AUTVAL,"failed. Notify database mgr. of incomplete SKIN TEST file."
  1.  ..Q
  1.  .Q
  1.  Q
  1. EXAM ;
  1.  W !,"Adding CPT code to exam entries."
  1.  S AUTT="EXAMCPT" F AUTJ=1:1 S AUTX=$T(@AUTT+AUTJ),AUTVAL=$P(AUTX,";;",2) Q:AUTVAL="QUIT"!(AUTVAL="")  D
  1.  .S AUTY=0 F  S AUTY=$O(^AUTTEXAM("C",AUTVAL,AUTY)) Q:AUTY'=+AUTY  D
  1.  ..S DA=AUTY,DIE="^AUTTEXAM(",DR=".11///"_$P(AUTX,";;",3) D ^DIE I $D(Y) W !,"Updating exam ",AUTVAL,"failed. Notify database mgr. of incomplete EXAM file."
  1.  ..Q
  1.  .Q
  1.  Q
  1. RCAT ;update recode category 9999999.081, field .01
  1.  W !,"Adding APC Recode Categories to Recode Category File.."
  1.  S DIC="^AUTTRCDC(",DIC(0)="L"
  1.  S AUTT="RCDC" F AUTJ=1:1 S AUTX=$T(@AUTT+AUTJ),AUTVAL=$P(AUTX,";;",2) Q:AUTVAL="QUIT"!(AUTVAL="")  D
  1.  .S X=AUTVAL D ^DIC I Y=-1 W "ADDING of Category ",AUTVAL," failed.. skipping.  Notify Database Manager."
  1.  .Q
  1.  K DIC,DD,DLAYGO,DA,DR
  1.  Q
  1. RECINJ ;update .02 and .04 of RECODE INJURY FILE
  1.  W !,"Adding Narrative and E-Codes to APC Injury code table..."
  1.  S AUTT="INJ02" F AUTJ=1:1 S AUTX=$T(@AUTT+AUTJ),AUTVAL=$P(AUTX,";;",2) Q:AUTVAL="QUIT"!(AUTVAL="")  D
  1.  .S AUTCAT=$P(AUTX,";;",4)
  1.  .S AUTICD=$P(AUTX,";;",3),AUTICD=$O(^ICD9("AB",AUTICD,0))
  1.  .I AUTICD="" W !!,"Can't find ICD code ",$P(AUTX,";;",3)," for APC code ",AUTVAL
  1.  .S AUTICD="`"_AUTICD
  1.  .S DA=$O(^AUTTRIJ("B",AUTVAL,0)) I DA="" W !,"Can't find entry ",AUTVAL," to edit.",! Q
  1.  .S DIE="^AUTTRIJ(",DR=".04///"_AUTCAT_";.02///"_AUTICD
  1.  .D ^DIE I $D(Y) W !,"Editing APC INJURY Code ",AUTVAL," failed, notify database mgr. of incomplete RECODE INJURY file."
  1.  .Q
  1.  Q
  1. PPT ;EP - add presentation types to presentation type file
  1.  W !,"Adding Pregnancy Presentation Types to Presentation Type file..."
  1.  S DIC="^AUTTPPT(",DIC(0)="L"
  1.  S AUTT="PPTTYPE" F AUTJ=1:1 S AUTX=$T(@AUTT+AUTJ),AUTVAL=$P(AUTX,";;",2) Q:AUTVAL="QUIT"!(AUTVAL="")  D
  1.  .S X=AUTVAL,DIC("DR")=".02////"_$P(AUTX,";;",3)_";.03////"_$P(AUTX,";;",4),DLAYGO=9999999.87 D ^DIC K DA I Y=-1 W !,"Adding Presentation Type ",X," failed. Notify database mgr. of incomplete PRESENTATION TYPE file.",!
  1.  .Q
  1.  K DIC,DD,DLAYGO,DR,DA,DD
  1.  Q
  1. EOJ2 ;
  1.  K AUTX,AUTVAL,AUTICD,AUTCAT
  1.  Q
  1. PPTTYPE ; presentation types
  1.  ;;VERTEX;;1;;VT
  1.  ;;COMPLETE BREECH;;2;;CB
  1.  ;;DOUBLE FOOTLING;;3;;DF
  1.  ;;SINGLE FOOTLING;;4;;SF
  1.  ;;FRANK BREECH;;5;;FB
  1.  ;;FACE;;6;;FA
  1.  ;;UNSPECIFIED BREECH;;7;;UB
  1.  ;;TRANSVERSE;;8;;TR
  1.  ;;OTHER;;9;;OT
  1.  ;;UNKNOWN;;U;;UNK
  1.  ;;QUIT
  1. RCDC ;
  1.  ;;INFECTIVE & PARASITIC DIS.
  1.  ;;NEOPLASMS
  1.  ;;ENDOCR., NUTR., & METAB. DIS.
  1.  ;;DIS. OF BLOOD & BLOOD-FORMING ORGANS
  1.  ;;MENTAL DISORDERS
  1.  ;;DIS. OF NERVOUS SYSTEM
  1.  ;;EYE DISEASES
  1.  ;;EAR DISEASES
  1.  ;;DIS. OF CIRCULATORY SYSTEM
  1.  ;;DIS. OF RESPIRATORY SYSTEM
  1.  ;;DIS. OF DIGESTIVE SYSTEM
  1.  ;;DIS. OF URINARY TRACT
  1.  ;;DIS. OF FEMALE GENITALIA & BREAST
  1.  ;;PREG., CHILDBIRTH & THE PUERPERIUM
  1.  ;;DIS. OF SKIN & SUBCUTANEOUS TISSUE
  1.  ;;MUSCULOSKEL SYSTEM & CONNECT. TISSUE
  1.  ;;CONGENITAL ANOMALIES
  1.  ;;SYMPTOMS & ILL-DEFINED CONDITION
  1.  ;;SUPPLEMENTAL
  1.  ;;ACCID. POISONINGS AND VIOLENCE
  1.  ;;ALL DIS., MALE GENIT. (EXCL VD)
  1.  ;;CAUSES OF PERNATAL MORB. & MORT.
  1.  ;;QUIT
  1. INJ02 ;
  1.  ;;01;;E819.9;;MOTOR VEHICLE ACCIDENT
  1.  ;;03;;E838.9;;WATER TRANSPORT
  1.  ;;04;;E844.9;;AIR TRANSPORT
  1.  ;;05;;E866.9;;ACCIDENTAL POISONING
  1.  ;;06;;E888.;;ACCIDENTAL FALLS
  1.  ;;07;;E899.;;FIRES AND FLAMES
  1.  ;;08;;E904.9;;ENVIRONMENTAL FACTORS
  1.  ;;09;;E905.9;;STINGS AND VENOMS
  1.  ;;10;;E906.9;;ANIMAL RELATED, INCLUDING BITES
  1.  ;;11;;E910.9;;DROWNING AND SUBMERSION
  1.  ;;12;;E920.9;;CUTTING AND PIERCING OBJECTS
  1.  ;;13;;E922.9;;FIREARMS ACCIDENTS
  1.  ;;14;;E919.9;;MACHINERY
  1.  ;;15;;E958.9;;SUICIDE ATTEMPT
  1.  ;;16;;E968.9;;INJ. PURPOSELY INFLICTED BY OTHERS
  1.  ;;17;;E967.9;;BATTERED CHILD
  1.  ;;18;;E988.9;;UNDETERMINED CAUSE
  1.  ;;19;;E988.8;;OTHER CAUSES
  1.  ;;QUIT
  1. IMMCPT ;
  1.  ;;01;;
  1.  ;;02;;90718
  1.  ;;03;;90701
  1.  ;;04;;90703
  1.  ;;05;;90714
  1.  ;;06;;90712
  1.  ;;07;;90713
  1.  ;;08;;
  1.  ;;09;;
  1.  ;;10;;
  1.  ;;11;;90705
  1.  ;;12;;90724
  1.  ;;13;;90725
  1.  ;;14;;90706
  1.  ;;15;;90704
  1.  ;;16;;90728
  1.  ;;17;;90707
  1.  ;;18;;90708
  1.  ;;19;;90732
  1.  ;;31;;90717
  1.  ;;32;;
  1.  ;;33;;90726
  1.  ;;34;;90702
  1.  ;;35;;90737
  1.  ;;37;;90737
  1.  ;;38;;90737
  1.  ;;39;;90737
  1.  ;;40;;90730
  1.  ;;41;;90716
  1.  ;;42;;90700
  1.  ;;QUIT
  1. EXAMCPT ;;
  1.  ;;01;;
  1.  ;;02;;
  1.  ;;03;;
  1.  ;;04;;
  1.  ;;05;;
  1.  ;;06;;
  1.  ;;07;;
  1.  ;;08;;
  1.  ;;09;;
  1.  ;;10;;
  1.  ;;11;;
  1.  ;;12;;
  1.  ;;14;;
  1.  ;;15;;57410
  1.  ;;16;;
  1.  ;;17;;92506
  1.  ;;18;;
  1.  ;;19;;92081
  1.  ;;20;;
  1.  ;;21;;92502
  1.  ;;22;;
  1.  ;;23;;92551
  1.  ;;24;;92552
  1.  ;;25;;92567
  1.  ;;26;;92100
  1.  ;;27;;
  1.  ;;28;;
  1.  ;;29;;
  1.  ;;QUIT
  1. SKCPT ;
  1.  ;;23;;86490
  1.  ;;24;;86585
  1.  ;;21;;86580
  1.  ;;22;;
  1.  ;;20;;86585
  1.  ;;QUIT