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 Nov 22, 2024@17:35:29 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 ;
