APCLPOS3.m

APCLPOS3 ; IHS/OHPRD/TMJ -CREATED BY ^XBERERTN ON APR 04, 1996 ;

 ;;3.0;IHS PCC REPORTS;;FEB 05, 1997

 ; This routine loads Routine ^ATXCHK

 ;

START ;

 S XBERPGM="ATXCHK"

 F I=1:1 S Y=$P($T(RTN+I),";;",2,99) Q:Y=""  S X="^TMP(""XBERPGM"",$J,"_I_",0)" S @X=Y

 S XCN=0,DIE="^TMP(""XBERPGM"","_$J_",",X=XBERPGM

 X ^%ZOSF("SAVE")

 K DIE,XCM,XCN

 S X=XBERPGM

 X ^%ZOSF("TEST")

 W !

 I $T W "Routine ^",XBERPGM," has been filed.",! I 1

 E  W "Saving of routine ^",XBERPGM," failed.",!

 K ^TMP("XBERPGM",$J)

 K XBERPGM,I,X,Y

 Q

 ;

RTN ; The routine to be loaded follows:

 ;;ATXCHK ; IHS/TUCSON/LAB - CHECK ICD CODES AGAINST TAXONOMY ;  [ 04/27/95  7:40 AM ]

 ;; ;;5.0;TAXONOMY SYSTEM;**1**;OCT 12, 1994

 ;; ;

 ;; ;IHS/TUCSON/LAB - changed VCODE+2 $D TO $E 02/27/95

 ;; ;

 ;;ICD(X,Y,Z) ;EP >>EXTRN FUNC to see if ICD code belongs in certain taxonomy

 ;; ;input variables: X=dx ifn, Y=taxonomy ifn, Z=9 for dx or 0 for proc

 ;; N ATXICD,ATXBEG,ATXEND,ATXFLG

 ;; S ATXFLG=0 I '$D(X)!'$D(Y)!'$D(Z) G EOJ

 ;; I (X="")!(Y="") G EOJ

 ;; S ATXICD=$S(Z=9:$P($G(^ICD9(X,0)),U),Z=0:$P($G(^ICD0(X,0)),U),1:"")

 ;; I ATXICD="" G EOJ

 ;; S ATXBEG=0

 ;; F  S ATXBEG=$O(^ATXAX(Y,21,"AA",ATXBEG)) Q:ATXBEG=""  Q:ATXFLG=1  D

 ;; .S ATXEND=$O(^ATXAX(Y,21,"AA",ATXBEG,0)) Q:ATXEND=""

 ;; .I ATXICD?1A.E D VCODE Q

 ;; .Q:ATXICD<ATXBEG  ;already passed code

 ;; .I ATXICD'>ATXEND S ATXFLG=1 Q  ;found code in taxonomy

 ;;EOJ Q ATXFLG

 ;; ;

 ;;VCODE ;checks v codes and e codes

 ;; I ATXBEG'?1A.E Q

 ;; I $E(ATXICD)'=$E(ATXBEG) Q  ;don't mix v and e codes ;ihs/tucson/lab changed $D to $E 2/27/95

 ;; Q:$E(ATXICD,2,9)<$E(ATXBEG,2,9)

 ;; I $E(ATXICD,2,9)'>$E(ATXEND,2,9) S ATXFLG=1

 ;; Q

APCLPOS3  ; IHS/OHPRD/TMJ -CREATED BY ^XBERERTN ON APR 04, 1996 ;

 +1       ;;3.0;IHS PCC REPORTS;;FEB 05, 1997

 +2       ; This routine loads Routine ^ATXCHK

 +3       ;

START     ;

 +1        SET XBERPGM="ATXCHK"

 +2        FOR I=1:1

               SET Y=$PIECE($TEXT(RTN+I),";;",2,99)

               IF Y=""

                   QUIT 

               SET X="^TMP(""XBERPGM"",$J,"_I_",0)"

               SET @X=Y

 +3        SET XCN=0

           SET DIE="^TMP(""XBERPGM"","_$JOB_","

           SET X=XBERPGM

 +4        XECUTE ^%ZOSF("SAVE")

 +5        KILL DIE,XCM,XCN

 +6        SET X=XBERPGM

 +7        XECUTE ^%ZOSF("TEST")

 +8        WRITE !

 +9        IF $TEST

               WRITE "Routine ^",XBERPGM," has been filed.",!

               IF 1

 +10      IF '$TEST

               WRITE "Saving of routine ^",XBERPGM," failed.",!

 +11       KILL ^TMP("XBERPGM",$JOB)

 +12       KILL XBERPGM,I,X,Y

 +13       QUIT 

 +14      ;

RTN       ; The routine to be loaded follows:

 +1       ;;ATXCHK ; IHS/TUCSON/LAB - CHECK ICD CODES AGAINST TAXONOMY ;  [ 04/27/95  7:40 AM ]

 +2       ;; ;;5.0;TAXONOMY SYSTEM;**1**;OCT 12, 1994

 +3       ;; ;

 +4       ;; ;IHS/TUCSON/LAB - changed VCODE+2 $D TO $E 02/27/95

 +5       ;; ;

 +6       ;;ICD(X,Y,Z) ;EP >>EXTRN FUNC to see if ICD code belongs in certain taxonomy

 +7       ;; ;input variables: X=dx ifn, Y=taxonomy ifn, Z=9 for dx or 0 for proc

 +8       ;; N ATXICD,ATXBEG,ATXEND,ATXFLG

 +9       ;; S ATXFLG=0 I '$D(X)!'$D(Y)!'$D(Z) G EOJ

 +10      ;; I (X="")!(Y="") G EOJ

 +11      ;; S ATXICD=$S(Z=9:$P($G(^ICD9(X,0)),U),Z=0:$P($G(^ICD0(X,0)),U),1:"")

 +12      ;; I ATXICD="" G EOJ

 +13      ;; S ATXBEG=0

 +14      ;; F  S ATXBEG=$O(^ATXAX(Y,21,"AA",ATXBEG)) Q:ATXBEG=""  Q:ATXFLG=1  D

 +15      ;; .S ATXEND=$O(^ATXAX(Y,21,"AA",ATXBEG,0)) Q:ATXEND=""

 +16      ;; .I ATXICD?1A.E D VCODE Q

 +17      ;; .Q:ATXICD<ATXBEG  ;already passed code

 +18      ;; .I ATXICD'>ATXEND S ATXFLG=1 Q  ;found code in taxonomy

 +19      ;;EOJ Q ATXFLG

 +20      ;; ;

 +21      ;;VCODE ;checks v codes and e codes

 +22      ;; I ATXBEG'?1A.E Q

 +23      ;; I $E(ATXICD)'=$E(ATXBEG) Q  ;don't mix v and e codes ;ihs/tucson/lab changed $D to $E 2/27/95

 +24      ;; Q:$E(ATXICD,2,9)<$E(ATXBEG,2,9)

 +25      ;; I $E(ATXICD,2,9)'>$E(ATXEND,2,9) S ATXFLG=1

 +26      ;; Q