- IBDFDE23 ;ALB/DHH - Select CPT Modifiers during Manual Data Entry ; MAY-18-1999
- ;;3.0;AUTOMATED INFO COLLECTION SYS;**38,37**;APR 24, 1997
- MOD ;Entry point for selecting or modifying modifiers
- ;
- ; -- called by IBDFDE21
- ;
- N CODE,I,X,SEL,MOD,Y,CNT,MODLST
- ;
- ;-- result is definition is noted in ^ibdfde2
- ; result:= pckg interface^code to send^text to send...
- ;
- S CODE=$P(RESULT(IBDX),"^",2)
- ;
- ; --ans = list number, cpt, or cpt-mod,mod (raw data user enters)
- ; if ans contains "-" then seperate and validate each cpt modifier pair
- ; if ans contains "-" ans should = cpt-mod,mod,mod...
- ; else ask for modifiers
- ;
- I ANS["-" D
- .S MODLST=$P(ANS,"-",2)
- .F I=1:1 S X=$P(MODLST,",",I) Q:X']"" D
- ..; --check for appropriate modifiers/cpt matches
- ..; cpts and modifiers can be input as
- ..; -- cpt-mod,mod,mod
- ..; if multiple modifiers were entered with cpt, each cpt-mod pair
- ..; will be checked by modp^icptmod to see if valid. if not, an
- ..; error message will be displayed for the invalid code pair
- ..;
- .. I $$MODP^ICPTMOD(CODE,X)'>0 D ERR Q
- .. S SEL("MOD",X)=""
- ;
- ; --no matter what method user uses to input data modifiers should
- ; should be asked for each cpt code
- ;
- D OTHER,ARRAY
- Q
- ;
- OTHER ;--allow for additional modifiers to be selected
- N DIC
- F S DIC=81.3,DIC("S")="I ($$MODP^ICPTMOD(CODE,+Y,""I""))>0",DIC(0)="AEMQ" D ^DIC Q:+Y<1 D
- . S MOD=$P($G(Y),"^",2)
- . I $D(SEL("MOD",MOD)) D DELMOD Q:Y=1
- . S:MOD'="" SEL("MOD",MOD)=""
- Q
- DELMOD ; Delete modifier from list if duplicate entry
- N DIR,DA,DR,DIC
- W !,"Do you want to remove this modifier as being Associated with this CPT Procedure?"
- S DIR(0)="Y",DIR("B")="YES" D ^DIR Q:$D(DIRUT)
- I Y=1 K SEL("MOD",MOD)
- Q
- ARRAY ; -- transfer modifier data to result array
- Q:'$D(SEL)
- S MOD="",CNT=0 F S MOD=$O(SEL("MOD",MOD)) Q:MOD']"" D
- . S CNT=CNT+1
- . S RESULT(IBDX,"MODIFIER",CNT)=MOD
- S RESULT(IBDX,"MODIFIER",0)=CNT
- Q
- ;
- ERR ;Error message
- W !,X," is not a valid modifier for ",CODE,!
- Q
- GAFSCOR ;Enter GAF Score
- ;GAFCNT is newed in % of IBDFDE,IBDFDE6,IBDFDE7
- S GAFCNT=$G(GAFCNT)+1
- I GAFCNT=2 Q
- I GAFCNT>2 K GAFCNT Q
- S DIR(0)="N^1:100"
- S DIR("A")="Enter GAF Score "
- S DIR("?")="GAF Score is numeric from 1-100."
- D ^DIR
- I Y<1 D G GAFSCOR
- . W "You must enter a GAF Score (1-100)!"
- . S GAFCNT=$G(GAFCNT)-1
- S IBDSEL(0)=$G(IBDSEL(0))+1
- S IBDSEL(IBDSEL(0))=IBDF("PI")_"^"_+Y_"^ ^^^^^GAF SCORE"
- S $P(PXCA("IBD GAF SCORE",0),"^")=+Y
- Q
- ;
- OKPROV(IEN) ; Screen for provider lookup using person class
- Q ($D(^XUSEC("SD GAF SCORE",IEN)))
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFDE23 2648 printed Feb 19, 2025@00:18:43 Page 2
- IBDFDE23 ;ALB/DHH - Select CPT Modifiers during Manual Data Entry ; MAY-18-1999
- +1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**38,37**;APR 24, 1997
- MOD ;Entry point for selecting or modifying modifiers
- +1 ;
- +2 ; -- called by IBDFDE21
- +3 ;
- +4 NEW CODE,I,X,SEL,MOD,Y,CNT,MODLST
- +5 ;
- +6 ;-- result is definition is noted in ^ibdfde2
- +7 ; result:= pckg interface^code to send^text to send...
- +8 ;
- +9 SET CODE=$PIECE(RESULT(IBDX),"^",2)
- +10 ;
- +11 ; --ans = list number, cpt, or cpt-mod,mod (raw data user enters)
- +12 ; if ans contains "-" then seperate and validate each cpt modifier pair
- +13 ; if ans contains "-" ans should = cpt-mod,mod,mod...
- +14 ; else ask for modifiers
- +15 ;
- +16 IF ANS["-"
- Begin DoDot:1
- +17 SET MODLST=$PIECE(ANS,"-",2)
- +18 FOR I=1:1
- SET X=$PIECE(MODLST,",",I)
- if X']""
- QUIT
- Begin DoDot:2
- +19 ; --check for appropriate modifiers/cpt matches
- +20 ; cpts and modifiers can be input as
- +21 ; -- cpt-mod,mod,mod
- +22 ; if multiple modifiers were entered with cpt, each cpt-mod pair
- +23 ; will be checked by modp^icptmod to see if valid. if not, an
- +24 ; error message will be displayed for the invalid code pair
- +25 ;
- +26 IF $$MODP^ICPTMOD(CODE,X)'>0
- DO ERR
- QUIT
- +27 SET SEL("MOD",X)=""
- End DoDot:2
- End DoDot:1
- +28 ;
- +29 ; --no matter what method user uses to input data modifiers should
- +30 ; should be asked for each cpt code
- +31 ;
- +32 DO OTHER
- DO ARRAY
- +33 QUIT
- +34 ;
- OTHER ;--allow for additional modifiers to be selected
- +1 NEW DIC
- +2 FOR
- SET DIC=81.3
- SET DIC("S")="I ($$MODP^ICPTMOD(CODE,+Y,""I""))>0"
- SET DIC(0)="AEMQ"
- DO ^DIC
- if +Y<1
- QUIT
- Begin DoDot:1
- +3 SET MOD=$PIECE($GET(Y),"^",2)
- +4 IF $DATA(SEL("MOD",MOD))
- DO DELMOD
- if Y=1
- QUIT
- +5 if MOD'=""
- SET SEL("MOD",MOD)=""
- End DoDot:1
- +6 QUIT
- DELMOD ; Delete modifier from list if duplicate entry
- +1 NEW DIR,DA,DR,DIC
- +2 WRITE !,"Do you want to remove this modifier as being Associated with this CPT Procedure?"
- +3 SET DIR(0)="Y"
- SET DIR("B")="YES"
- DO ^DIR
- if $DATA(DIRUT)
- QUIT
- +4 IF Y=1
- KILL SEL("MOD",MOD)
- +5 QUIT
- ARRAY ; -- transfer modifier data to result array
- +1 if '$DATA(SEL)
- QUIT
- +2 SET MOD=""
- SET CNT=0
- FOR
- SET MOD=$ORDER(SEL("MOD",MOD))
- if MOD']""
- QUIT
- Begin DoDot:1
- +3 SET CNT=CNT+1
- +4 SET RESULT(IBDX,"MODIFIER",CNT)=MOD
- End DoDot:1
- +5 SET RESULT(IBDX,"MODIFIER",0)=CNT
- +6 QUIT
- +7 ;
- ERR ;Error message
- +1 WRITE !,X," is not a valid modifier for ",CODE,!
- +2 QUIT
- GAFSCOR ;Enter GAF Score
- +1 ;GAFCNT is newed in % of IBDFDE,IBDFDE6,IBDFDE7
- +2 SET GAFCNT=$GET(GAFCNT)+1
- +3 IF GAFCNT=2
- QUIT
- +4 IF GAFCNT>2
- KILL GAFCNT
- QUIT
- +5 SET DIR(0)="N^1:100"
- +6 SET DIR("A")="Enter GAF Score "
- +7 SET DIR("?")="GAF Score is numeric from 1-100."
- +8 DO ^DIR
- +9 IF Y<1
- Begin DoDot:1
- +10 WRITE "You must enter a GAF Score (1-100)!"
- +11 SET GAFCNT=$GET(GAFCNT)-1
- End DoDot:1
- GOTO GAFSCOR
- +12 SET IBDSEL(0)=$GET(IBDSEL(0))+1
- +13 SET IBDSEL(IBDSEL(0))=IBDF("PI")_"^"_+Y_"^ ^^^^^GAF SCORE"
- +14 SET $PIECE(PXCA("IBD GAF SCORE",0),"^")=+Y
- +15 QUIT
- +16 ;
- OKPROV(IEN) ; Screen for provider lookup using person class
- +1 QUIT ($DATA(^XUSEC("SD GAF SCORE",IEN)))
- +2 ;