PXCECPT1 ;ISA/DHH/BDB - Used to edit and display V CPT ;15 May 2012 10:10 PM
;;1.0;PCE PATIENT CARE ENCOUNTER;**170,164,199**;Aug 12, 1996;Build 51
;; ;
Q
ICDEN ;diagnosis lookup using lexicon
;
I $G(X)="?BAD" S Y=-1 Q
I $G(X)["?" Q
K Y N DIC,PXACS,PXACSREC,PXDATE,PXDEF,PXXX
S PXDATE=$S($D(PXCEVIEN)=1:$$CSDATE^PXDXUTL(PXCEVIEN),$D(PXCEAPDT)=1:PXCEAPDT,1:DT)
S PXACSREC=$$ACTDT^PXDXUTL(PXDATE),PXACS=$P(PXACSREC,"^",3)
I PXACS["-" S PXACS=$P(PXACS,"-",1,2)
I $P(PXACSREC,U,1)'="ICD" D
. S PXDEF=$G(X),PXAGAIN=0 D ^PXDSLK I PXXX=-1 S Y=-1 Q
. S Y($P(PXACSREC,U,2))=$P($P(PXXX,U,1),";",2)
. S Y=$P(PXXX,";",1)_U_$P(PXXX,U,2)
I $P(PXACSREC,U,1)="ICD" D
. D CONFIG^LEXSET($P(PXACSREC,U,1),,PXDATE)
. S DIC(0)=""
. S DIC="^LEX(757.01,",DIC(0)=$S('$L($G(X)):"",1:"")_"EQM"
. S DIC("A")="Enter "_PXACS_" Diagnosis: "
. D ^DIC
Q:Y=-1
S X=$G(Y($P(PXACSREC,U,2))),(X,Y)=$P($$ICDDATA^ICDXCODE("DIAG",X,PXDATE,"E"),U,1)
Q
;
DEPART ;PX*1.0*164 Set the Department Code to the Clinic AMIS Reporting Stop Code
Q:'$$SWSTAT^IBBAPI() D
. I $P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))="",$P($G(^AUPNVSIT(PXCEVIEN,0)),"^",8) D
.. S $P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))=$P($G(^DIC(40.7,$P(^AUPNVSIT(PXCEVIEN,0),"^",8),0)),"^",2)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXCECPT1 1303 printed Oct 16, 2024@18:28:38 Page 2
PXCECPT1 ;ISA/DHH/BDB - Used to edit and display V CPT ;15 May 2012 10:10 PM
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**170,164,199**;Aug 12, 1996;Build 51
+2 ;; ;
+3 QUIT
ICDEN ;diagnosis lookup using lexicon
+1 ;
+2 IF $GET(X)="?BAD"
SET Y=-1
QUIT
+3 IF $GET(X)["?"
QUIT
+4 KILL Y
NEW DIC,PXACS,PXACSREC,PXDATE,PXDEF,PXXX
+5 SET PXDATE=$SELECT($DATA(PXCEVIEN)=1:$$CSDATE^PXDXUTL(PXCEVIEN),$DATA(PXCEAPDT)=1:PXCEAPDT,1:DT)
+6 SET PXACSREC=$$ACTDT^PXDXUTL(PXDATE)
SET PXACS=$PIECE(PXACSREC,"^",3)
+7 IF PXACS["-"
SET PXACS=$PIECE(PXACS,"-",1,2)
+8 IF $PIECE(PXACSREC,U,1)'="ICD"
Begin DoDot:1
+9 SET PXDEF=$GET(X)
SET PXAGAIN=0
DO ^PXDSLK
IF PXXX=-1
SET Y=-1
QUIT
+10 SET Y($PIECE(PXACSREC,U,2))=$PIECE($PIECE(PXXX,U,1),";",2)
+11 SET Y=$PIECE(PXXX,";",1)_U_$PIECE(PXXX,U,2)
End DoDot:1
+12 IF $PIECE(PXACSREC,U,1)="ICD"
Begin DoDot:1
+13 DO CONFIG^LEXSET($PIECE(PXACSREC,U,1),,PXDATE)
+14 SET DIC(0)=""
+15 SET DIC="^LEX(757.01,"
SET DIC(0)=$SELECT('$LENGTH($GET(X)):"",1:"")_"EQM"
+16 SET DIC("A")="Enter "_PXACS_" Diagnosis: "
+17 DO ^DIC
End DoDot:1
+18 if Y=-1
QUIT
+19 SET X=$GET(Y($PIECE(PXACSREC,U,2)))
SET (X,Y)=$PIECE($$ICDDATA^ICDXCODE("DIAG",X,PXDATE,"E"),U,1)
+20 QUIT
+21 ;
DEPART ;PX*1.0*164 Set the Department Code to the Clinic AMIS Reporting Stop Code
+1 if '$$SWSTAT^IBBAPI()
QUIT
Begin DoDot:1
+2 IF $PIECE(PXCEAFTR($PIECE(PXCETEXT,"~",1)),"^",$PIECE(PXCETEXT,"~",2))=""
IF $PIECE($GET(^AUPNVSIT(PXCEVIEN,0)),"^",8)
Begin DoDot:2
+3 SET $PIECE(PXCEAFTR($PIECE(PXCETEXT,"~",1)),"^",$PIECE(PXCETEXT,"~",2))=$PIECE($GET(^DIC(40.7,$PIECE(^AUPNVSIT(PXCEVIEN,0),"^",8),0)),"^",2)
End DoDot:2
End DoDot:1
+4 QUIT
