9:25 AM  17-NOV-97
AUMDX ROUTINE FOR PATCH AUM*97.1*11
AUMDX
AUMDX ;IHS/DSD/AEF FINDS BAD X-REFS IN ICD9 AND ICD0 GLOBALS [ 11/17/97  8:50 AM ]
 ;;97.1;ICD UPDATE;**1**;NOV 4, 1997
 ;;Y2K/OK AEF/2971028
 ;
 ;This routine will loop through the 'BA' crossreferences in the ICD
 ;Diagnosis and ICD Operation/Procedure files and compare the entry
 ;in each x-ref with the contents of the first piece of the zero node
 ;of the pointed to entry to see if they match.  Those that don't
 ;match will be printed on the report produced by this routine.
 ;
EN ;EP -- MAIN ENTRY POINT
 ;
 D ^XBKVAR,HOME^%ZIS
 D QUE("DQ^AUMDX","ICD DIAGNOSIS FILE 'BA' X-REF MISMATCH RPT")
 Q
DQ ;EP -- QUEUED JOB STARTS HERE
 ;
 D BA
 D PRT
 D QUIT
 Q
BA ;----- LOOP THROUGH THE 'BA' CROSSREFERENCE TO FIND MISMATCHES
 ;
 N CNT,CODE,GLOB,ICD,IFN,NOT,Q
 S Q=""""
 K ^TMP("AUMD",$J)
 F GLOB="ICD9","ICD0" D
 . S ICD=0 F  S ICD=$O(@("^"_GLOB_"("_ICD_")")) Q:'ICD  D
 . . S CODE=$P(@("^"_GLOB_"("_ICD_",0)"),U)
 . . S ^TMP("AUMD",$J,GLOB,1,CODE)=""
 F GLOB="ICD9","ICD0" D
 . S ICD=9999 F  S ICD=$O(@("^"_GLOB_"("_"""BA"""_","_Q_ICD_Q_")")) Q:$P(ICD," ")']""  D
 . . S IFN=0 F  S IFN=$O(@("^"_GLOB_"("_"""BA"""_","_Q_ICD_Q_","_IFN_")")) Q:'IFN  D
 . . . I '$D(@("^"_GLOB_"("_IFN_",0)")) S CNT=CNT+1,^TMP("AUMD",$J,GLOB,2,CNT)=IFN_U_ICD_U_U_"IFN NOT IN FILE" Q
 . . . S CODE=$P(@("^"_GLOB_"("_IFN_",0)"),U)
 . . . I CODE'=$P(ICD," ") D
 . . . . S CNT=$G(CNT)+1,NOT=""
 . . . . I '$D(^TMP("AUMD",$J,GLOB,1,$P(ICD," "))) S NOT=ICD_" NOT IN FILE"
 . . . . S ^TMP("AUMD",$J,GLOB,2,CNT)=IFN_U_ICD_U_CODE_U_$G(NOT)
 Q
PRT ;----- PRINT THE REPORT
 ;
 N DATA,GLOB,NOW,OUT,PAGE,SITE,X
 D ^XBKVAR
 S SITE=$P(^DIC(4,DUZ(2),0),U)
 S OUT=0
 F GLOB="ICD9","ICD0" D  Q:OUT
 . D HDR Q:OUT
 . I '$D(^TMP("AUMD",$J,GLOB,2)) W !!,"NO RECORDS TO PRINT" Q
 . S X=0 F  S X=$O(^TMP("AUMD",$J,GLOB,2,X)) Q:'X  D  Q:OUT
 . . I $Y>(IOSL-7) D HDR Q:OUT
 . . S DATA=^TMP("AUMD",$J,GLOB,2,X)
 . . W !!,$P(DATA,U,1),?16,$P(DATA,U,2),?30,$P(DATA,U,3),?50,$P(DATA,U,4)
 Q:OUT
 D QUES
 Q
HDR ;----- HEADER
 ;
 N %,DIR,I,X,Y
 I $E(IOST)="C",$G(PAGE) S DIR(0)="E" D ^DIR K DIR I 'Y S OUT=1 Q
 S PAGE=$G(PAGE)+1
 W @IOF
 W "ICD "_$S(GLOB="ICD9":"DIAGNOSIS",GLOB="ICD0":"OPERATION/PROCEDURE",1:"")_" FILE 'BA' X-REF MISMATCHES"
 W ?(IOM-17),$$NOW
 W !,"SITE:  ",SITE
 W ?(IOM-10),"PAGE ",PAGE
 W !!,"INTERNAL",?16,"CODE IN",?30,"POINTS TO"
 W !,"NUMBER",?15,"'BA X-REF'",?30,"CODE"
 W ! F I=1:1:IOM W "-"
 Q
QUES ;----- PRINTS LAST PAGE QUESTIONNAIRE
 ;
 N %,DIR,X,Y
 I $E(IOST)="C",$G(PAGE) S DIR(0)="E" D ^DIR K DIR I 'Y S OUT=1 Q
 W @IOF
 S PAGE=$G(PAGE)+1
 W ?(IOM-17),$$NOW
 W !,"SITE: ",SITE
 W ?(IOM-10),"PAGE ",PAGE
 W !!,"ICD CODE QUESTIONNAIRE"
 W !!!,"1. Has the ICD Diagnosis or ICD Operation/Procedure file been re-indexed"
 W !,"   since installing ICD Updates V97.1?"
 W !,"   __ Yes    __ No"
 W !!,"   If yes:"
 W !!,"   1a.  When were the files re-indexed?"
 W !!,"   1b.  For what reason?"
 W !!!!!,"If there are no items on the report and the answer to question 1 is No, then"
 W !,"skip the rest of this questionnaire, enter your name and phone number at"
 W !,"the bottom, and mail or fax the report and questionnaire to Headquarters West"
 W !!!,"2. When did your site install ICD Updates V97.1?"
 W !!,"3. What has been installed on your system since the installation of ICD Updates"
 W !,"   V97.1, i.e., software packages, patches, commercial software, and when?"
 W !!!!!!!,"4. Have users noticed any ICD codes 'changing', for example, a 410"
 W !,"   heart attack code changes to a 207 leukemia code in a patient's record?"
 W !!,"   If yes:"
 W !!,"   4a. Which codes changed?"
 W !!!!!!,"   4b. When was this first noticed?"
 W !!!!,"Your Name: _________________________"
 W !!,"Phone #: ___________________________"
 W !!,"Fax to: Anne Fugatt",?30,"Mail to: Anne Fugatt"
 W !,"        (505)248-4199",?30,"         Division of Information Resources/DSD"
 W !?30,"         5300 Homestead Rd., NE"
 W !?30,"         Albuquerque, NM  87110"
 Q
NOW() ;----- EXTRINSIC FUNCTION RETURNS NOW
 ;
 N %,%H,%I,X,Y
 D NOW^%DTC
 S Y=X
 X ^DD("DD")
 S NOW=Y_"@"_$E($P(%,".",2),1,2)_":"_$E($P(%,".",2),3,4)
 Q NOW
 ;
QUE(ZTRTN,ZTDESC)  ;
 ;EP -- QUEUEING CODE
 ;
 N %ZIS,IO,POP,ZTIO,ZTSK
 S %ZIS="Q" D ^%ZIS Q:POP
 I $D(IO("Q")) K IO("Q") S ZTIO=ION_";"_IOST_";"_IOSL D ^%ZTLOAD I $G(ZTSK) W !,"Task #",$G(ZTSK)," queued"
 E  D @ZTRTN
 Q
QUIT ;----- CLEANUP AND QUIT
 ;
 K ^TMP("AUMD",$J)
 K ZTDESC,ZTRTN
 D ^%ZISC
 Q