- AUPNSICD ;OHPRD/LAB,SCK - Screen Purpose of Visit/ICD9 codes ; 15 May 2012 10:05 PM
- ;;1.0;PCE PATIENT CARE ENCOUNTER;**121,149,190,194,199**;Aug 12, 1996;Build 51
- ;;93.2;IHS PATIENT DICTIONARIES.;;JUL 01, 1993
- ;; Modified Feb. 2012 for ICD-10 project. T.J.Holloway
- ;
- N ICDSTR,ICDVDT,X
- ; Define variable PXCEVIEN - PX*1*190
- I '$D(PXCEVIEN) S PXCEVIEN="" I DA,$G(^AUPNVPOV(DA,0)) S PXCEVIEN=$P(^AUPNVPOV(DA,0),U,3)
- S ICDVDT=$$CSDATE^PXDXUTL(PXCEVIEN)
- S ICDSTR=$$ICDDATA^ICDXCODE("DIAG",Y,ICDVDT,"I")
- ;
- ;**************************************************************************
- ;** if the user is a VA employee jump down to line tag VAIN **
- ;**************************************************************************
- 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)
- I $P(ICDSTR,U,11)=""!($P(ICDSTR,U,11)=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(ICDSTR,U,10)=1
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HAUPNSICD 1611 printed Mar 13, 2025@21:30:12 Page 2
- AUPNSICD ;OHPRD/LAB,SCK - Screen Purpose of Visit/ICD9 codes ; 15 May 2012 10:05 PM
- +1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**121,149,190,194,199**;Aug 12, 1996;Build 51
- +2 ;;93.2;IHS PATIENT DICTIONARIES.;;JUL 01, 1993
- +3 ;; Modified Feb. 2012 for ICD-10 project. T.J.Holloway
- +4 ;
- +5 NEW ICDSTR,ICDVDT,X
- +6 ; Define variable PXCEVIEN - PX*1*190
- +7 IF '$DATA(PXCEVIEN)
- SET PXCEVIEN=""
- IF DA
- IF $GET(^AUPNVPOV(DA,0))
- SET PXCEVIEN=$PIECE(^AUPNVPOV(DA,0),U,3)
- +8 SET ICDVDT=$$CSDATE^PXDXUTL(PXCEVIEN)
- +9 SET ICDSTR=$$ICDDATA^ICDXCODE("DIAG",Y,ICDVDT,"I")
- +10 ;
- +11 ;**************************************************************************
- +12 ;** if the user is a VA employee jump down to line tag VAIN **
- +13 ;**************************************************************************
- +14 if $GET(DUZ("AG"))="V"
- GOTO VAIN
- +15 ;
- +16 ;I 1 Q:$G(DUZ("AG"))'="I"
- EIN ; SCREEN OUT E CODES AND INACTIVE CODES
- +1 ;I $E(^ICD9(Y,0),U,1)'="E",$P(^(0),U,9)=""
- +2 ;I $P(^ICD9(Y,0),U,1)'="E",$P(^(0),U,9)=""
- +3 IF $PIECE(ICDSTR,U,2)'="E"
- IF $PIECE(ICDSTR,U,10)=1
- +4 if '$TEST
- GOTO XIT
- SEX ; IF 'USE WITH SEX' FIELD HAS A VALUE CHECK THAT VALUE AGAINST AUPNSEX
- +1 if '$DATA(AUPNSEX)
- GOTO AGE
- +2 ;I $P(^ICD9(Y,0),U,10)=""!($P(^ICD9(Y,0),U,10)=AUPNSEX)
- +3 IF $PIECE(ICDSTR,U,11)=""!($PIECE(ICDSTR,U,11)=AUPNSEX)
- +4 if '$TEST
- GOTO XIT
- AGE ; IF THERE IS AGE CRITERIA DATA AVAILABLE CHECK TO SEE THAT IT FITS THE CRITERIA
- +1 ;G:'$D(AUPNDAYS) XIT
- +2 ;G:'$D(^ICD9(Y,9999999)) XIT
- +3 ;I $P(^(9999999),U,1)=""!($P(^(9999999),U,1)<AUPNDAYS)
- +4 ;G:'$T XIT
- +5 ;I $P(^(9999999),U,2)=""!($P(^(9999999),U,2)>AUPNDAYS)
- XIT ;
- +1 KILL DA,PXCEVIEN
- +2 QUIT
- +3 ;
- VAIN ;SCREEN OUT INACTIVE CODES
- +1 ; E codes are ok in the VA
- +2 IF $PIECE(ICDSTR,U,10)=1
- +3 QUIT
- +4 ;
