Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PXCECPT1

PXCECPT1.m

Go to the documentation of this file.
  1. 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
  1. ;; ;
  1. Q
  1. ICDEN ;diagnosis lookup using lexicon
  1. ;
  1. I $G(X)="?BAD" S Y=-1 Q
  1. I $G(X)["?" Q
  1. K Y N DIC,PXACS,PXACSREC,PXDATE,PXDEF,PXXX
  1. S PXDATE=$S($D(PXCEVIEN)=1:$$CSDATE^PXDXUTL(PXCEVIEN),$D(PXCEAPDT)=1:PXCEAPDT,1:DT)
  1. S PXACSREC=$$ACTDT^PXDXUTL(PXDATE),PXACS=$P(PXACSREC,"^",3)
  1. I PXACS["-" S PXACS=$P(PXACS,"-",1,2)
  1. I $P(PXACSREC,U,1)'="ICD" D
  1. . S PXDEF=$G(X),PXAGAIN=0 D ^PXDSLK I PXXX=-1 S Y=-1 Q
  1. . S Y($P(PXACSREC,U,2))=$P($P(PXXX,U,1),";",2)
  1. . S Y=$P(PXXX,";",1)_U_$P(PXXX,U,2)
  1. I $P(PXACSREC,U,1)="ICD" D
  1. . D CONFIG^LEXSET($P(PXACSREC,U,1),,PXDATE)
  1. . S DIC(0)=""
  1. . S DIC="^LEX(757.01,",DIC(0)=$S('$L($G(X)):"",1:"")_"EQM"
  1. . S DIC("A")="Enter "_PXACS_" Diagnosis: "
  1. . D ^DIC
  1. Q:Y=-1
  1. S X=$G(Y($P(PXACSREC,U,2))),(X,Y)=$P($$ICDDATA^ICDXCODE("DIAG",X,PXDATE,"E"),U,1)
  1. Q
  1. ;
  1. DEPART ;PX*1.0*164 Set the Department Code to the Clinic AMIS Reporting Stop Code
  1. Q:'$$SWSTAT^IBBAPI() D
  1. . I $P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))="",$P($G(^AUPNVSIT(PXCEVIEN,0)),"^",8) D
  1. .. S $P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))=$P($G(^DIC(40.7,$P(^AUPNVSIT(PXCEVIEN,0),"^",8),0)),"^",2)
  1. Q