source: FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDFN4.m@ 1683

Last change on this file since 1683 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 4.2 KB
Line 
1IBDFN4 ;ALB/CJM - ENCOUNTER FORM - (entry points for selection routines);5/21/93
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;**38,51**;APR 24, 1997
3 ;
4CPT ;select ambulatory procedures
5 N NAME,CODE,SCREEN,IBDESCR,IBDESCLG,QUIT
6 S QUIT=0
7 ;;I '$D(@IBARY@("SCREEN")) D CPTSCRN Q:QUIT
8 ;;E S SCREEN=$G(@IBARY@("SCREEN"))
9 S SCREEN="I $P($$CPT^ICPTCOD(Y),U,7)=1" ;List only active codes
10 K DIC S DIC=81,DIC(0)="AEMQZ",DIC("S")=SCREEN
11 I $D(^ICPT) D ^DIC K DIC I +Y>0 D
12 .;;change to api cpt;dhh
13 .S CODE=$P(Y(0),U)
14 .S CODE=$$CPT^ICPTCOD(CODE)
15 .I +CODE=-1 K @IBARY Q
16 .S NAME=$P(CODE,"^",3)
17 .S IBDESCLG=$$CPTD^ICPTCOD(+CODE,.IBCPTD)
18 .S IBDESCR=$G(IBCPTD(1))_" "_$G(IBCPTD(2))
19 .S @IBARY=$P(CODE,"^",2)_"^"_NAME_"^"_IBDESCR
20 E K @IBARY ;kill either if file doesn't exist or nothing chosen
21 Q
22CPTSCRN ;This code is probably not called, but will modify to be safe.
23 ;;S SCREEN="I '$P(^(0),U,4)"
24 S SCREEN="I $P($$CPT^ICPTCOD(Y),U,7)=1"
25 ;
26 ;don't ask the user about categories - it doesn't work well
27 ;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"
28 ;I $D(^DIC(81.1)) D ^DIR K DIR S:$D(DIRUT) QUIT=1 Q:$D(DIRUT) I +Y D
29 ;.K DIC S DIC="81.1",DIC(0)="AEQ",DIC("S")="I $P(^(0),U,2)=""m"""
30 ;.D ^DIC K DIC I +Y>0 S SCREEN=SCREEN_",$P($G(^DIC(81.1,+$P(^(0),U,3),0)),U,3)="_+Y
31 S @IBARY@("SCREEN")=SCREEN
32 Q
33 ;
34ICD9 ;select ICD-9 codes
35 N IBDX,CODE,SCREEN,IBDESCR,QUIT
36 S QUIT=0
37 ;;I $D(@IBARY@("SCREEN")) S SCREEN=$G(@IBARY@("SCREEN"))
38 ;;E D ICD9SCRN Q:QUIT
39 S SCREEN="I $P($$ICDDX^ICDCODE(Y),U,10)=1" ;List only active codes
40 S DIC=80,DIC(0)="AEMQZI",DIC("S")=SCREEN
41 I $D(^ICD9) D ^DIC K DIC I +Y>0 D
42 .S CODE=$P(Y(0),U),IBDX=$P(Y(0),U,3),IBDESCR=$P($G(^ICD9(+Y,1)),"^")
43 .S @IBARY=CODE_"^"_IBDX_"^"_IBDESCR
44 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
45 Q
46ICD9SCRN ;This code is probably not called, but will modify to be safe.
47 ;;S SCREEN="I '$P(^(0),U,9)"
48 S SCREEN="I $P($$ICDDX^ICDCODE(Y),U,10)=1"
49 ;
50 ;don't ask the user about categories - it doesn't work well
51 ;K DIR S DIR(0)="YA",DIR("A")="Do you want to select an ICD diagnosis from a particular diagnostic category? ",DIR("B")="NO"
52 ;S DIR("?")="Answer YES if you want to screen out all diagnosis codes that do not belong to a particular category"
53 ;I $D(^DIC(80.3)) D ^DIR K DIR S:$D(DIRUT) QUIT=1 Q:$D(DIRUT) I +Y D
54 ;.K DIC S DIC="80.3",DIC(0)="AEQ"
55 ;.D ^DIC K DIC I +Y>0 S SCREEN=SCREEN_",+$P(^(0),U,5)="_+Y
56 S @IBARY@("SCREEN")=SCREEN
57 Q
58NULL ;returns NOTHING for selection
59 S @IBARY=""
60 Q
61 ;
62VSIT ; -- Select only visit cpt codes
63 N NAME,CODE,IBDESCR,QUIT,DIC,X,Y,IBHDR,IBTXT
64 S QUIT=0
65 ;
66 ;;S DIC="^IBE(357.69,",DIC(0)="AEMQZ",DIC("S")="I '$P(^(0),U,4)"
67 S DIC="^IBE(357.69,",DIC(0)="AEMQZ"
68 S DIC("S")="I $P($$CPT^ICPTCOD(Y),U,7)=1" ;List only active codes
69 D ^DIC K DIC I +Y>0 D
70 .;;----change to api cpt;dhh
71 .S CODE=$P(Y(0),U),IBHDR=$P(Y(0),U,2),IBTXT=$P(Y(0),U,3)
72 .S NODE=$$CPT^ICPTCOD(CODE)
73 .I +NODE=-1 S IBSNM="" Q
74 .S IBSNM=$P(NODE,U,3)
75 .S @IBARY=CODE_"^"_IBTXT_"^"_IBHDR_"^"_IBSNM
76 E K @IBARY ;kill if nothing chosen
77 Q
78 ;
79PRVDR ;for selecting provider
80 D GETPRO^IBDF18B(IBCLINIC,IBARY)
81 Q
82 ;
83IBPFID ;for printing the form # assigned by form tracking
84 S @IBARY=$G(IBPFID)
85 Q
86 ;
87PCPR ; -- get primary care provider for a patient
88 S @IBARY=$P($$OUTPTPR^SDUTL3(DFN,DT),"^",2)
89 Q
90 ;
91PCTM ; -- get primary care team for a patient
92 S @IBARY=$P($$OUTPTTM^SDUTL3(DFN,DT),"^",2)
93 Q
94 ;
95SCCOND ; -- display sc conditions
96 Q:'$G(DFN)
97 D DIS^DGRPDB
98 W !
99 Q
100 ;
101 ;
102CPTMOD ;- Select active CPT Modifiers
103 ;- (used in selecting CPT Modifier(s) when creating the CPT Modifier
104 ; Display ToolKit Block)
105 ;
106 N CODE,DIC,NAME,SCREEN
107 Q:$G(IBARY)=""
108 ;
109 ;- Screen out inactive CPT modifiers
110 ;;S SCREEN="I '$P(^(0),U,5)"
111 ;;I '$D(@IBARY@("SCREEN")) S @IBARY@("SCREEN")=SCREEN
112 ;
113 ;List only active modifiers
114 S SCREEN="I $P($$MOD^ICPTMOD(Y,""I""),U,7)=1"
115 S DIC=81.3
116 S DIC(0)="AEMQZ"
117 S DIC("S")=SCREEN
118 D ^DIC
119 I +Y>0 D
120 . ;- Use first 35 chars of modifier description
121 . S CODE=$P(Y(0),"^"),NAME=$E($P(Y(0),"^",2),1,35)
122 . S @IBARY=CODE_"^"_NAME
123 ;
124 ;- Kill if file doesn't exist or nothing chosen
125 E K @IBARY
126 Q
Note: See TracBrowser for help on using the repository browser.