Ignore:
Timestamp:
Dec 4, 2009, 12:11:15 AM (15 years ago)
Author:
George Lilly
Message:

revised back to 6/30/08 version

File:
1 edited

Legend:

Unmodified
Added
Removed
  • WorldVistAEHR/trunk/r/IHS_ROUTINES-AUP/AUPNSICD.m

    r613 r623  
    1 AUPNSICD        ;OHPRD/LAB - Screen Purpose of Visit/ICD9 codes ; 5/1/03 11:52am
    2         ;;1.0;PCE PATIENT CARE ENCOUNTER;**121,149,190**;Aug 12, 1996;Build 9
    3         ;;93.2;IHS PATIENT DICTIONARIES.;;JUL 01, 1993
    4         ;
    5         N ICDSTR,ICDVDT
    6         ; Define variable PXCEVIEN - PX*1*190
    7         I '$D(PXCEVIEN) I DA I $G(^AUPNVPOV(DA,0)) S PXCEVIEN=$P(^AUPNVPOV(DA,0),U,3)
    8         ;S ICDSTR=$$ICDDX^ICDCODE(Y,$P(^AUPNVSIT(PXCEVIEN,0),"^",2))
    9         S ICDSTR=$$ICDDX^ICDCODE(Y,+^AUPNVSIT(PXCEVIEN,0)),ICDVDT=+^AUPNVSIT(PXCEVIEN,0)
    10         G:$G(DUZ("AG"))="V" VAIN
    11         ;
    12         ;I 1 Q:$G(DUZ("AG"))'="I"
    13 EIN     ; SCREEN OUT E CODES AND INACTIVE CODES
    14         ;I $E(^ICD9(Y,0),U,1)'="E",$P(^(0),U,9)=""
    15         ;I $P(^ICD9(Y,0),U,1)'="E",$P(^(0),U,9)=""
    16         I $P(ICDSTR,U,2)'="E",$P(ICDSTR,U,10)=1
    17         G:'$T XIT
    18 SEX     ; IF 'USE WITH SEX' FIELD HAS A VALUE CHECK THAT VALUE AGAINST AUPNSEX
    19         G:'$D(AUPNSEX) AGE
    20         I $P(^ICD9(Y,0),U,10)=""!($P(^ICD9(Y,0),U,10)=AUPNSEX)
    21         G:'$T XIT
    22 AGE     ; IF THERE IS AGE CRITERIA DATA AVAILABLE CHECK TO SEE THAT IT FITS THE CRITERIA
    23         ;G:'$D(AUPNDAYS) XIT
    24         ;G:'$D(^ICD9(Y,9999999)) XIT
    25         ;I $P(^(9999999),U,1)=""!($P(^(9999999),U,1)<AUPNDAYS)
    26         ;G:'$T XIT
    27         ;I $P(^(9999999),U,2)=""!($P(^(9999999),U,2)>AUPNDAYS)
    28 XIT     ;
    29         K DA,PXCEVIEN
    30         Q
    31         ;
    32 VAIN    ;SCREEN OUT INACTIVE CODES
    33         ; E codes are ok in the VA
    34         ;I $P(^ICD9(Y,0),U,9)'=1
    35         I $P(ICDSTR,U,10)=1
    36         Q
    37         ;
     1AUPNSICD ;OHPRD/LAB - Screen Purpose of Visit/ICD9 codes ; 5/1/03 11:52am
     2 ;;1.0;PCE PATIENT CARE ENCOUNTER;**121,149**;Aug 12, 1996
     3 ;;93.2;IHS PATIENT DICTIONARIES.;;JUL 01, 1993
     4 ;
     5 N ICDSTR,ICDVDT
     6 ;S ICDSTR=$$ICDDX^ICDCODE(Y,$P(^AUPNVSIT(PXCEVIEN,0),"^",2))
     7 S ICDSTR=$$ICDDX^ICDCODE(Y,+^AUPNVSIT(PXCEVIEN,0)),ICDVDT=+^AUPNVSIT(PXCEVIEN,0)
     8 G:$G(DUZ("AG"))="V" VAIN
     9 ;
     10 ;I 1 Q:$G(DUZ("AG"))'="I"
     11EIN ; SCREEN OUT E CODES AND INACTIVE CODES
     12 ;I $E(^ICD9(Y,0),U,1)'="E",$P(^(0),U,9)=""
     13 ;I $P(^ICD9(Y,0),U,1)'="E",$P(^(0),U,9)=""
     14 I $P(ICDSTR,U,2)'="E",$P(ICDSTR,U,10)=1
     15 G:'$T XIT
     16SEX ; IF 'USE WITH SEX' FIELD HAS A VALUE CHECK THAT VALUE AGAINST AUPNSEX
     17 G:'$D(AUPNSEX) AGE
     18 I $P(^ICD9(Y,0),U,10)=""!($P(^ICD9(Y,0),U,10)=AUPNSEX)
     19 G:'$T XIT
     20AGE ; IF THERE IS AGE CRITERIA DATA AVAILABLE CHECK TO SEE THAT IT FITS THE CRITERIA
     21 ;G:'$D(AUPNDAYS) XIT
     22 ;G:'$D(^ICD9(Y,9999999)) XIT
     23 ;I $P(^(9999999),U,1)=""!($P(^(9999999),U,1)<AUPNDAYS)
     24 ;G:'$T XIT
     25 ;I $P(^(9999999),U,2)=""!($P(^(9999999),U,2)>AUPNDAYS)
     26XIT ;
     27 Q
     28 ;
     29VAIN ;SCREEN OUT INACTIVE CODES
     30 ; E codes are ok in the VA
     31 ;I $P(^ICD9(Y,0),U,9)'=1
     32 I $P(ICDSTR,U,10)=1
     33 Q
     34 ;
Note: See TracChangeset for help on using the changeset viewer.