Changeset 623 for WorldVistAEHR/trunk/r/IHS_ROUTINES-AUP/AUPNSICD.m

Timestamp:

Dec 4, 2009, 12:11:15 AM (14 years ago)

Author:

George Lilly

Message:

revised back to 6/30/08 version

File:

• WorldVistAEHR/trunk/r/IHS_ROUTINES-AUP/AUPNSICD.m (modified) (1 diff)

WorldVistAEHR/trunk/r/IHS_ROUTINES-AUP/AUPNSICD.m

@@ -1 @@
-AUPNSICD        ;OHPRD/LAB - Screen Purpose of Visit/ICD9 codes ; 5/1/03 11:52am
-        ;;1.0;PCE PATIENT CARE ENCOUNTER;**121,149,190**;Aug 12, 1996;Build 9
-        ;;93.2;IHS PATIENT DICTIONARIES.;;JUL 01, 1993
-        ;
-        N ICDSTR,ICDVDT
-        ; Define variable PXCEVIEN - PX*1*190
-        I '$D(PXCEVIEN) I DA I $G(^AUPNVPOV(DA,0)) S PXCEVIEN=$P(^AUPNVPOV(DA,0),U,3)
-        ;S ICDSTR=$$ICDDX^ICDCODE(Y,$P(^AUPNVSIT(PXCEVIEN,0),"^",2))
-        S ICDSTR=$$ICDDX^ICDCODE(Y,+^AUPNVSIT(PXCEVIEN,0)),ICDVDT=+^AUPNVSIT(PXCEVIEN,0)
-        G:$G(DUZ("AG"))="V" VAIN
-        ;
-        ;I 1 Q:$G(DUZ("AG"))'="I"
-EIN     ; SCREEN OUT E CODES AND INACTIVE CODES
-        ;I $E(^ICD9(Y,0),U,1)'="E",$P(^(0),U,9)=""
-        ;I $P(^ICD9(Y,0),U,1)'="E",$P(^(0),U,9)=""
-        I $P(ICDSTR,U,2)'="E",$P(ICDSTR,U,10)=1
-        G:'$T XIT
-SEX     ; IF 'USE WITH SEX' FIELD HAS A VALUE CHECK THAT VALUE AGAINST AUPNSEX
-        G:'$D(AUPNSEX) AGE
-        I $P(^ICD9(Y,0),U,10)=""!($P(^ICD9(Y,0),U,10)=AUPNSEX)
-        G:'$T XIT
-AGE     ; IF THERE IS AGE CRITERIA DATA AVAILABLE CHECK TO SEE THAT IT FITS THE CRITERIA
-        ;G:'$D(AUPNDAYS) XIT
-        ;G:'$D(^ICD9(Y,9999999)) XIT
-        ;I $P(^(9999999),U,1)=""!($P(^(9999999),U,1)<AUPNDAYS)
-        ;G:'$T XIT
-        ;I $P(^(9999999),U,2)=""!($P(^(9999999),U,2)>AUPNDAYS)
-XIT     ;
-        K DA,PXCEVIEN
-        Q
-        ;
-VAIN    ;SCREEN OUT INACTIVE CODES
-        ; E codes are ok in the VA
-        ;I $P(^ICD9(Y,0),U,9)'=1
-        I $P(ICDSTR,U,10)=1
-        Q
-        ;
+AUPNSICD ;OHPRD/LAB - Screen Purpose of Visit/ICD9 codes ; 5/1/03 11:52am
+ ;;1.0;PCE PATIENT CARE ENCOUNTER;**121,149**;Aug 12, 1996
+ ;;93.2;IHS PATIENT DICTIONARIES.;;JUL 01, 1993
+ ;
+ N ICDSTR,ICDVDT
+ ;S ICDSTR=$$ICDDX^ICDCODE(Y,$P(^AUPNVSIT(PXCEVIEN,0),"^",2))
+ S ICDSTR=$$ICDDX^ICDCODE(Y,+^AUPNVSIT(PXCEVIEN,0)),ICDVDT=+^AUPNVSIT(PXCEVIEN,0)
+ G:$G(DUZ("AG"))="V" VAIN
+ ;
+ ;I 1 Q:$G(DUZ("AG"))'="I"
+EIN ; SCREEN OUT E CODES AND INACTIVE CODES
+ ;I $E(^ICD9(Y,0),U,1)'="E",$P(^(0),U,9)=""
+ ;I $P(^ICD9(Y,0),U,1)'="E",$P(^(0),U,9)=""
+ I $P(ICDSTR,U,2)'="E",$P(ICDSTR,U,10)=1
+ G:'$T XIT
+SEX ; IF 'USE WITH SEX' FIELD HAS A VALUE CHECK THAT VALUE AGAINST AUPNSEX
+ G:'$D(AUPNSEX) AGE
+ I $P(^ICD9(Y,0),U,10)=""!($P(^ICD9(Y,0),U,10)=AUPNSEX)
+ G:'$T XIT
+AGE ; IF THERE IS AGE CRITERIA DATA AVAILABLE CHECK TO SEE THAT IT FITS THE CRITERIA
+ ;G:'$D(AUPNDAYS) XIT
+ ;G:'$D(^ICD9(Y,9999999)) XIT
+ ;I $P(^(9999999),U,1)=""!($P(^(9999999),U,1)<AUPNDAYS)
+ ;G:'$T XIT
+ ;I $P(^(9999999),U,2)=""!($P(^(9999999),U,2)>AUPNDAYS)
+XIT ;
+ Q
+ ;
+VAIN ;SCREEN OUT INACTIVE CODES
+ ; E codes are ok in the VA
+ ;I $P(^ICD9(Y,0),U,9)'=1
+ I $P(ICDSTR,U,10)=1
+ Q
+ ;