SDAMBAE3.m

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 ---SDAMBAE3   1138     printed  Apr 23, 2025@19:01:55                                                                                                                                                                                                    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