- 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 Feb 18, 2025@23:54:13 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