SDAMBAE3 ;ALB/BOK/MJK - ADD/EDIT CON'T ;7/8/91 12:18 ;
;;5.3;Scheduling;**18,29,40,111,132,556**;Aug 13, 1993;Build 3
;
DUP ; -- inp transform to check for duplicate CPTs in ^DD(409.51,21:25,0)
; variable '%' is passed and defined as the piece beinging edited
;
F C=0:0 S C=$O(^SDV("AP",DA(1),C)) Q:'C I $D(^SDV(DA(1),"CS",C,"PR")) S Y=^("PR") F I=1:1:5 I $S(C'=DA:1,1:I'=%),$P(Y,U,I)=X D DUPMES G DUPQ
DUPQ K C Q
;
DUPMES ;
N SDX S SDX=$$CPT^ICPTCOD(X)
W !?2,*7,"WARNING: '",$P(SDX,U,3),"' has already been entered for this",!?11,"patient on this VISIT DATE(Entry #",C,").",!!?11,"Procedure will be added again."
K SDX
Q
;
SCREEN ; -- screen logic for 409.51 proc fields
; finds status for effective date DA(1)
I $P($$CPT^ICPTCOD(Y,$P(DA(1),".")),U,7)
Q
;
ID ; -- DIC("W") logic for amb proc look-ups
N SDICPT,SDICPT1,SDIX
S SDICPT1=$$CPT^ICPTCOD(Y,D)
Q:SDICPT1<0
W ?4,$P(SDICPT1,U,3)
I '$P(SDICPT1,U,7) W !?10,"** INACTIVE **"
;
; print code description
S SDICPT=$$CPTD^ICPTCOD(Y,"SDICPT") F SDIX=1:1:SDICPT W !?10,SDICPT(SDIX)
; set $TEST
W !?9 I +$$CPT^ICPTCOD(Y)>0
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDAMBAE3 1138 printed Dec 13, 2024@02:47:25 Page 2
SDAMBAE3 ;ALB/BOK/MJK - ADD/EDIT CON'T ;7/8/91 12:18 ;
+1 ;;5.3;Scheduling;**18,29,40,111,132,556**;Aug 13, 1993;Build 3
+2 ;
DUP ; -- inp transform to check for duplicate CPTs in ^DD(409.51,21:25,0)
+1 ; variable '%' is passed and defined as the piece beinging edited
+2 ;
+3 FOR C=0:0
SET C=$ORDER(^SDV("AP",DA(1),C))
if 'C
QUIT
IF $DATA(^SDV(DA(1),"CS",C,"PR"))
SET Y=^("PR")
FOR I=1:1:5
IF $SELECT(C'=DA:1,1:I'=%)
IF $PIECE(Y,U,I)=X
DO DUPMES
GOTO DUPQ
DUPQ KILL C
QUIT
+1 ;
DUPMES ;
+1 NEW SDX
SET SDX=$$CPT^ICPTCOD(X)
+2 WRITE !?2,*7,"WARNING: '",$PIECE(SDX,U,3),"' has already been entered for this",!?11,"patient on this VISIT DATE(Entry #",C,").",!!?11,"Procedure will be added again."
+3 KILL SDX
+4 QUIT
+5 ;
SCREEN ; -- screen logic for 409.51 proc fields
+1 ; finds status for effective date DA(1)
+2 IF $PIECE($$CPT^ICPTCOD(Y,$PIECE(DA(1),".")),U,7)
+3 QUIT
+4 ;
ID ; -- DIC("W") logic for amb proc look-ups
+1 NEW SDICPT,SDICPT1,SDIX
+2 SET SDICPT1=$$CPT^ICPTCOD(Y,D)
+3 if SDICPT1<0
QUIT
+4 WRITE ?4,$PIECE(SDICPT1,U,3)
+5 IF '$PIECE(SDICPT1,U,7)
WRITE !?10,"** INACTIVE **"
+6 ;
+7 ; print code description
+8 SET SDICPT=$$CPTD^ICPTCOD(Y,"SDICPT")
FOR SDIX=1:1:SDICPT
WRITE !?10,SDICPT(SDIX)
+9 ; set $TEST
+10 WRITE !?9
IF +$$CPT^ICPTCOD(Y)>0
+11 QUIT
