- IBDFN4 ;ALB/CJM - ENCOUNTER FORM - (entry points for selection routines);5/21/93
- ;;3.0;AUTOMATED INFO COLLECTION SYS;**38**;APR 24, 1997
- ;
- CPT ;select ambulatory procedures
- N NAME,CODE,SCREEN,IBDESCR,IBDESCLG,QUIT
- S QUIT=0
- I '$D(@IBARY@("SCREEN")) D CPTSCRN Q:QUIT
- E S SCREEN=$G(@IBARY@("SCREEN"))
- K DIC S DIC=81,DIC(0)="AEMQZ",DIC("S")=SCREEN
- I $D(^ICPT) D ^DIC K DIC I +Y>0 D
- .;;change to api cpt;dhh
- .S CODE=$P(Y(0),U)
- .S CODE=$$CPT^ICPTCOD(CODE)
- .I +CODE=-1 K @IBARY Q
- .S NAME=$P(CODE,"^",3)
- .S IBDESCLG=$$CPTD^ICPTCOD(+CODE,.IBCPTD)
- .S IBDESCR=$G(IBCPTD(1))_" "_$G(IBCPTD(2))
- .S @IBARY=$P(CODE,"^",2)_"^"_NAME_"^"_IBDESCR
- E K @IBARY ;kill either if file doesn't exist or nothing chosen
- Q
- CPTSCRN ;
- S SCREEN="I '$P(^(0),U,4)"
- ;
- ;don't ask the user about categories - it doesn't work well
- ;K DIR S DIR(0)="YA",DIR("A")="Do you want to select a CPT from a particular CPT category? ",DIR("?")="Answer YES if you want to screen out all CPT codes that do not belong to a particular category",DIR("B")="NO"
- ;I $D(^DIC(81.1)) D ^DIR K DIR S:$D(DIRUT) QUIT=1 Q:$D(DIRUT) I +Y D
- ;.K DIC S DIC="81.1",DIC(0)="AEQ",DIC("S")="I $P(^(0),U,2)=""m"""
- ;.D ^DIC K DIC I +Y>0 S SCREEN=SCREEN_",$P($G(^DIC(81.1,+$P(^(0),U,3),0)),U,3)="_+Y
- S @IBARY@("SCREEN")=SCREEN
- Q
- ;
- ICD9 ;select ICD-9 codes
- N IBDX,CODE,SCREEN,IBDESCR,QUIT
- S QUIT=0
- I $D(@IBARY@("SCREEN")) S SCREEN=$G(@IBARY@("SCREEN"))
- E D ICD9SCRN Q:QUIT
- S DIC=80,DIC(0)="AEMQZI",DIC("S")=SCREEN
- I $D(^ICD9) D ^DIC K DIC I +Y>0 D
- .S CODE=$P(Y(0),U),IBDX=$P(Y(0),U,3),IBDESCR=$P($G(^ICD9(+Y,1)),"^")
- .S @IBARY=CODE_"^"_IBDX_"^"_IBDESCR
- E K @IBARY ;kill if either file doesn't exist or nothing chosen - this is how to let the encounter form utilities know nothing was selected
- Q
- ICD9SCRN ;
- S SCREEN="I '$P(^(0),U,9)"
- ;
- ;don't ask the user about categories - it doesn't work well
- ;K DIR S DIR(0)="YA",DIR("A")="Do you want to select an ICD diagnosis from a particular diagnostic category? ",DIR("B")="NO"
- ;S DIR("?")="Answer YES if you want to screen out all diagnosis codes that do not belong to a particular category"
- ;I $D(^DIC(80.3)) D ^DIR K DIR S:$D(DIRUT) QUIT=1 Q:$D(DIRUT) I +Y D
- ;.K DIC S DIC="80.3",DIC(0)="AEQ"
- ;.D ^DIC K DIC I +Y>0 S SCREEN=SCREEN_",+$P(^(0),U,5)="_+Y
- S @IBARY@("SCREEN")=SCREEN
- Q
- NULL ;returns NOTHING for selection
- S @IBARY=""
- Q
- ;
- VSIT ; -- Select only visit cpt codes
- N NAME,CODE,IBDESCR,QUIT,DIC,X,Y,IBHDR,IBTXT
- S QUIT=0
- ;
- S DIC="^IBE(357.69,",DIC(0)="AEMQZ",DIC("S")="I '$P(^(0),U,4)"
- D ^DIC K DIC I +Y>0 D
- .;;----change to api cpt;dhh
- .S CODE=$P(Y(0),U),IBHDR=$P(Y(0),U,2),IBTXT=$P(Y(0),U,3)
- .S NODE=$$CPT^ICPTCOD(CODE)
- .I +NODE=-1 S IBSNM="" Q
- .S IBSNM=$P(NODE,U,3)
- .S @IBARY=CODE_"^"_IBTXT_"^"_IBHDR_"^"_IBSNM
- E K @IBARY ;kill if nothing chosen
- Q
- ;
- PRVDR ;for selecting provider
- D GETPRO^IBDF18B(IBCLINIC,IBARY)
- Q
- ;
- IBPFID ;for printing the form # assigned by form tracking
- S @IBARY=$G(IBPFID)
- Q
- ;
- PCPR ; -- get primary care provider for a patient
- S @IBARY=$P($$OUTPTPR^SDUTL3(DFN,DT),"^",2)
- Q
- ;
- PCTM ; -- get primary care team for a patient
- S @IBARY=$P($$OUTPTTM^SDUTL3(DFN,DT),"^",2)
- Q
- ;
- SCCOND ; -- display sc conditions
- Q:'$G(DFN)
- D DIS^DGRPDB
- W !
- Q
- ;
- ;
- CPTMOD ;- Select active CPT Modifiers
- ;- (used in selecting CPT Modifier(s) when creating the CPT Modifier
- ; Display ToolKit Block)
- ;
- N CODE,DIC,NAME,SCREEN
- Q:$G(IBARY)=""
- ;
- ;- Screen out inactive CPT modifiers
- S SCREEN="I '$P(^(0),U,5)"
- I '$D(@IBARY@("SCREEN")) S @IBARY@("SCREEN")=SCREEN
- S DIC=81.3
- S DIC(0)="AEMQZ"
- S DIC("S")=SCREEN
- D ^DIC
- I +Y>0 D
- . ;- Use first 35 chars of modifier description
- . S CODE=$P(Y(0),"^"),NAME=$E($P(Y(0),"^",2),1,35)
- . S @IBARY=CODE_"^"_NAME
- ;
- ;- Kill if file doesn't exist or nothing chosen
- E K @IBARY
- Q
- IBDFN4 ;ALB/CJM - ENCOUNTER FORM - (entry points for selection routines);5/21/93
- +1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**38**;APR 24, 1997
- +2 ;
- CPT ;select ambulatory procedures
- +1 NEW NAME,CODE,SCREEN,IBDESCR,IBDESCLG,QUIT
- +2 SET QUIT=0
- +3 IF '$DATA(@IBARY@("SCREEN"))
- DO CPTSCRN
- IF QUIT
- QUIT
- +4 IF '$TEST
- SET SCREEN=$GET(@IBARY@("SCREEN"))
- +5 KILL DIC
- SET DIC=81
- SET DIC(0)="AEMQZ"
- SET DIC("S")=SCREEN
- +6 IF $DATA(^ICPT)
- DO ^DIC
- KILL DIC
- IF +Y>0
- Begin DoDot:1
- +7 ;;change to api cpt;dhh
- +8 SET CODE=$PIECE(Y(0),U)
- +9 SET CODE=$$CPT^ICPTCOD(CODE)
- +10 IF +CODE=-1
- KILL @IBARY
- QUIT
- +11 SET NAME=$PIECE(CODE,"^",3)
- +12 SET IBDESCLG=$$CPTD^ICPTCOD(+CODE,.IBCPTD)
- +13 SET IBDESCR=$GET(IBCPTD(1))_" "_$GET(IBCPTD(2))
- +14 SET @IBARY=$PIECE(CODE,"^",2)_"^"_NAME_"^"_IBDESCR
- End DoDot:1
- +15 ;kill either if file doesn't exist or nothing chosen
- IF '$TEST
- KILL @IBARY
- +16 QUIT
- CPTSCRN ;
- +1 SET SCREEN="I '$P(^(0),U,4)"
- +2 ;
- +3 ;don't ask the user about categories - it doesn't work well
- +4 ;K DIR S DIR(0)="YA",DIR("A")="Do you want to select a CPT from a particular CPT category? ",DIR("?")="Answer YES if you want to screen out all CPT codes that do not belong to a particular category",DIR("B")="NO"
- +5 ;I $D(^DIC(81.1)) D ^DIR K DIR S:$D(DIRUT) QUIT=1 Q:$D(DIRUT) I +Y D
- +6 ;.K DIC S DIC="81.1",DIC(0)="AEQ",DIC("S")="I $P(^(0),U,2)=""m"""
- +7 ;.D ^DIC K DIC I +Y>0 S SCREEN=SCREEN_",$P($G(^DIC(81.1,+$P(^(0),U,3),0)),U,3)="_+Y
- +8 SET @IBARY@("SCREEN")=SCREEN
- +9 QUIT
- +10 ;
- ICD9 ;select ICD-9 codes
- +1 NEW IBDX,CODE,SCREEN,IBDESCR,QUIT
- +2 SET QUIT=0
- +3 IF $DATA(@IBARY@("SCREEN"))
- SET SCREEN=$GET(@IBARY@("SCREEN"))
- +4 IF '$TEST
- DO ICD9SCRN
- IF QUIT
- QUIT
- +5 SET DIC=80
- SET DIC(0)="AEMQZI"
- SET DIC("S")=SCREEN
- +6 IF $DATA(^ICD9)
- DO ^DIC
- KILL DIC
- IF +Y>0
- Begin DoDot:1
- +7 SET CODE=$PIECE(Y(0),U)
- SET IBDX=$PIECE(Y(0),U,3)
- SET IBDESCR=$PIECE($GET(^ICD9(+Y,1)),"^")
- +8 SET @IBARY=CODE_"^"_IBDX_"^"_IBDESCR
- End DoDot:1
- +9 ;kill if either file doesn't exist or nothing chosen - this is how to let the encounter form utilities know nothing was selected
- IF '$TEST
- KILL @IBARY
- +10 QUIT
- ICD9SCRN ;
- +1 SET SCREEN="I '$P(^(0),U,9)"
- +2 ;
- +3 ;don't ask the user about categories - it doesn't work well
- +4 ;K DIR S DIR(0)="YA",DIR("A")="Do you want to select an ICD diagnosis from a particular diagnostic category? ",DIR("B")="NO"
- +5 ;S DIR("?")="Answer YES if you want to screen out all diagnosis codes that do not belong to a particular category"
- +6 ;I $D(^DIC(80.3)) D ^DIR K DIR S:$D(DIRUT) QUIT=1 Q:$D(DIRUT) I +Y D
- +7 ;.K DIC S DIC="80.3",DIC(0)="AEQ"
- +8 ;.D ^DIC K DIC I +Y>0 S SCREEN=SCREEN_",+$P(^(0),U,5)="_+Y
- +9 SET @IBARY@("SCREEN")=SCREEN
- +10 QUIT
- NULL ;returns NOTHING for selection
- +1 SET @IBARY=""
- +2 QUIT
- +3 ;
- VSIT ; -- Select only visit cpt codes
- +1 NEW NAME,CODE,IBDESCR,QUIT,DIC,X,Y,IBHDR,IBTXT
- +2 SET QUIT=0
- +3 ;
- +4 SET DIC="^IBE(357.69,"
- SET DIC(0)="AEMQZ"
- SET DIC("S")="I '$P(^(0),U,4)"
- +5 DO ^DIC
- KILL DIC
- IF +Y>0
- Begin DoDot:1
- +6 ;;----change to api cpt;dhh
- +7 SET CODE=$PIECE(Y(0),U)
- SET IBHDR=$PIECE(Y(0),U,2)
- SET IBTXT=$PIECE(Y(0),U,3)
- +8 SET NODE=$$CPT^ICPTCOD(CODE)
- +9 IF +NODE=-1
- SET IBSNM=""
- QUIT
- +10 SET IBSNM=$PIECE(NODE,U,3)
- +11 SET @IBARY=CODE_"^"_IBTXT_"^"_IBHDR_"^"_IBSNM
- End DoDot:1
- +12 ;kill if nothing chosen
- IF '$TEST
- KILL @IBARY
- +13 QUIT
- +14 ;
- PRVDR ;for selecting provider
- +1 DO GETPRO^IBDF18B(IBCLINIC,IBARY)
- +2 QUIT
- +3 ;
- IBPFID ;for printing the form # assigned by form tracking
- +1 SET @IBARY=$GET(IBPFID)
- +2 QUIT
- +3 ;
- PCPR ; -- get primary care provider for a patient
- +1 SET @IBARY=$PIECE($$OUTPTPR^SDUTL3(DFN,DT),"^",2)
- +2 QUIT
- +3 ;
- PCTM ; -- get primary care team for a patient
- +1 SET @IBARY=$PIECE($$OUTPTTM^SDUTL3(DFN,DT),"^",2)
- +2 QUIT
- +3 ;
- SCCOND ; -- display sc conditions
- +1 IF '$GET(DFN)
- QUIT
- +2 DO DIS^DGRPDB
- +3 WRITE !
- +4 QUIT
- +5 ;
- +6 ;
- CPTMOD ;- Select active CPT Modifiers
- +1 ;- (used in selecting CPT Modifier(s) when creating the CPT Modifier
- +2 ; Display ToolKit Block)
- +3 ;
- +4 NEW CODE,DIC,NAME,SCREEN
- +5 IF $GET(IBARY)=""
- QUIT
- +6 ;
- +7 ;- Screen out inactive CPT modifiers
- +8 SET SCREEN="I '$P(^(0),U,5)"
- +9 IF '$DATA(@IBARY@("SCREEN"))
- SET @IBARY@("SCREEN")=SCREEN
- +10 SET DIC=81.3
- +11 SET DIC(0)="AEMQZ"
- +12 SET DIC("S")=SCREEN
- +13 DO ^DIC
- +14 IF +Y>0
- Begin DoDot:1
- +15 ;- Use first 35 chars of modifier description
- +16 SET CODE=$PIECE(Y(0),"^")
- SET NAME=$EXTRACT($PIECE(Y(0),"^",2),1,35)
- +17 SET @IBARY=CODE_"^"_NAME
- End DoDot:1
- +18 ;
- +19 ;- Kill if file doesn't exist or nothing chosen
- +20 IF '$TEST
- KILL @IBARY
- +21 QUIT