source: WorldVistAEHR/trunk/r/PCE_PATIENT_CARE_ENCOUNTER-AUTN-EFDP-PX-VSIT--PXRM/PXBGCPT4.m@ 1806

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

initial load of WorldVistAEHR

File size: 4.4 KB
Line 
1PXBGCPT4 ;ISL/JVS,ESW - DOUBLE ?? GATHERING OF FORM PROCEDURES ; 5/7/03 3:35pm
2 ;;1.0;PCE PATIENT CARE ENCOUNTER;**11,73,43,108,121**;Aug 12, 1996
3 ;
4 ;
5 ;
6 W !,"THIS IS NOT AN ENTRY POINT" Q
7 ;
8 ;
9DOUBLE1(FROM) ;--Entry point
10 ;
11NEW ;
12 ;
13 N FILE,FIELD,TITLE,HEADING,SUB,NAME,START,SCREEN,OK,INDEX,CYCLE
14 N TOTAL,PRV,CNT,PXBPMT,CODE,SUB2,SUBM,MODSTR,CNUM,MNUM,CONT,QT,PXMDIEN
15 ;---SETUP VARIABLES
16 S BACK="",INDEX=""
17 S START=DATA,(CONT,SUB,SUB2,SUBM)=0
18 ;
19START1 ;--RECYCLE POINT
20 S TITLE="- - F O R M P R O C E D U R E S - -"
21 ;
22 D GETLST^IBDF18A(CLINIC,$P($T(CPT^PXBAICS),";;",2),"PXBPMT",,,1,IDATE)
23 ;
24 S TOTAL=PXBPMT(0)
25 I PXBPMT(0)>0 D
26 .S (SUB,CNT)=""
27 .F S SUB=$O(PXBPMT(SUB)) Q:SUB="" D
28 ..S CODE=$P(PXBPMT(SUB),U)
29 ..I '(CODE?5N!(CODE?1A4N)!(CODE?4N1A)) Q ;PX*1.0*108
30 ..;I $P($G(^ICPT($O(^ICPT("B",CODE,0)),0)),U,4) Q
31 ..I '$P($$CPT^ICPTCOD(CODE,IDATE),U,7) Q
32 ..S NAME=$P(PXBPMT(SUB),U,2)
33 ..S CNT=CNT+1
34 ..S ^TMP("PXBTOTAL",$J,"DILIST","ID",CNT,.01)=CODE
35 ..S ^TMP("PXBTOTAL",$J,"DILIST","ID",CNT,2)=NAME
36 ..S SUBM=0
37 ..F S SUBM=$O(PXBPMT(SUB,"MODIFIER",SUBM)) Q:SUBM="" D
38 ...S PXMDIEN=+$$MODP^ICPTMOD(CODE,PXBPMT(SUB,"MODIFIER",SUBM),"E",IDATE)
39 ...S MODSTR=$$MOD^ICPTMOD(PXMDIEN,"I",IDATE)
40 ...I +MODSTR>0,$P(MODSTR,U,7) D
41 ....S ^TMP("PXBTOTAL",$J,"DILIST","ID",CNT,"MODIFIER",SUBM)=$P(MODSTR,U,2)_U_$P(MODSTR,U,3)
42 I $D(CNT) S TOTAL=CNT
43 ;
44 ;--DISPLAY IF NO MATCH FOUND
45 I TOTAL=0 W IOCUU,IOCUU,!,IOELEOL D
46 .;D LOC,HEAD
47 .D LOC W !
48 .S RESULTS="NO PROCEDURE BLOCKS EXIST FOR AN ENCOUNTER FORM"
49 .W !!!,?(IOM-$L(RESULTS))\2,RESULTS
50 .D HELP1^PXBUTL1("CON")
51 .R OK:DTIME
52 I TOTAL=0 S TOTAL="^C" Q TOTAL
53 ;
54 ;
55 ;----DISPLAY LIST TO THE SCREEN
56 S HEADING="W !,""ITEM"",?6,""CODE"",?13,""DESCRIPTION "",IOINHI,TOTAL,"" ENTRIES"",IOINLOW"
57 ;
58LIST ;-DISPLAY LIST TO THE SCREEN
59 ;D LOC,HEAD
60 D LOC W !
61 X HEADING
62 S SUB=$P(CONT,U)-1
63 S (QT,CNUM,MNUM)=0
64 F S SUB=$O(^TMP("PXBTOTAL",$J,"DILIST","ID",SUB)) Q:SUB'>0 S SUB2=SUB2+1 D Q:QT
65 .S CNUM=CNUM+1
66 .I CNUM+MNUM=11 S CONT=SUB_U_0,QT=1 Q
67 .S CODE=$G(^TMP("PXBTOTAL",$J,"DILIST","ID",SUB,.01))
68 .S NAME=$G(^TMP("PXBTOTAL",$J,"DILIST","ID",SUB,2))
69 .W !,SUB,?6,CODE,?13,NAME
70 .S SUBM=$P(CONT,U,2)-1
71 .S:$P(CONT,U,2)>0 $P(CONT,U,2)=0
72 .F S SUBM=$O(^TMP("PXBTOTAL",$J,"DILIST","ID",SUB,"MODIFIER",SUBM)) Q:SUBM="" D Q:QT
73 ..S MNUM=MNUM+1
74 ..I MNUM+CNUM=11 S CONT=SUB_U_SUBM,QT=1 Q
75 ..S MODSTR=^TMP("PXBTOTAL",$J,"DILIST","ID",SUB,"MODIFIER",SUBM)
76 ..W !?6,"CPT Modifier:",?21,$P(MODSTR,U),?25,$P(MODSTR,U,2)
77 ;
78 ;----If There is only one selection go to proper prompting
79 I TOTAL=1 G PRMPT2
80 ;
81PRMPT ;---WRITE PROMPT HERE
82 D WIN17^PXBCC(PXBCNT)
83 D LOC^PXBCC(15,1)
84 W !
85 I SUB>0 W !,"Enter '^' to quit"
86 E I TOTAL>10 W !," END OF LIST"
87 I SUB>0 S DIR("A")="Select a single 'ITEM NUMBER' or 'RETURN' to continue: "
88 E S DIR("A")="Select a single 'ITEM NUMBER' or 'RETURN' to exit: "
89 S DIR("?")="Enter ITEM 'No' to select , '^' to quit"
90 S DIR(0)="N,A,O^0:"_SUB2_":0^I X'?.1""^"".N K X"
91 D ^DIR
92 I X="",SUB>0 G LIST
93 I X="",SUB'>0 S X="^"
94 I $G(DIRUT) K DIRUT S VAL="^C" G EXITNEW
95VAL ;-----Set the VAL equal to the value
96 S VAL=$G(^TMP("PXBTOTAL",$J,"DILIST","ID",X,2))_"^"_$G(^TMP("PXBTOTAL",$J,"DILIST","ID",X,.01))
97 S (MODSTR,SUBM)=""
98 F S SUBM=$O(^TMP("PXBTOTAL",$J,"DILIST","ID",X,"MODIFIER",SUBM)) Q:SUBM="" D
99 .S MODSTR=MODSTR_$S(MODSTR]"":",",1:"")_$P(^TMP("PXBTOTAL",$J,"DILIST","ID",X,"MODIFIER",SUBM),U)
100EXITNEW ;--EXIT
101 K DIR,^TMP("PXBTANA",$J),^TMP("PXBTOTAL",$J)
102 K TANA,TOTAL
103 Q VAL_U_$G(MODSTR)
104 ;
105 ;-----------------SUBROUTINES--------------
106BACK ;
107 S START=$G(^TMP("PXBTANA",$J,"DILIST",1,1))
108 S START("IEN")=$G(^TMP("PXBTANA",$J,"DILIST",2,1))
109 Q
110FORWARD ;
111 S START=$G(^TMP("PXBTANA",$J,"DILIST",1,10))
112 S START("IEN")=$G(^TMP("PXBTANA",$J,"DILIST",2,10))
113 Q
114LOC ;--LOCATE CURSOR
115 D LOC^PXBCC(3,1) ;--LOCATE THE CURSOR
116 W IOEDEOP ;--CLEAR THE PAGE
117 Q
118HEAD ;--HEAD
119 W !,IOCUU,IOBON,"HELP SCREEN",IOSGR0
120 W ?(IOM-$L(TITLE))\2,IOINHI,TITLE,IOINLOW,IOELEOL
121 Q
122SUB ;--DISPLAY LIST TO THE SCREEN
123 I $P(^TMP("PXBTANA",$J,"DILIST",0),"^",1)=0 W !!," E N D O F L I S T" Q
124 X HEADING
125 S SUB=0,CNT=0
126 F S SUB=$O(^TMP("PXBTANA",$J,"DILIST","ID",SUB)) Q:SUB'>0 S CNT=CNT+1 D
127 .S NAME=$G(^TMP("PXBTANA",$J,"DILIST","ID",SUB,.01))
128 .W !,SUB,?6,NAME
129 Q
130SETUP ;-SETP VARIABLES
131 S FILE=200,FIELD=.01
132 S HEADING="W !,""ITEM"",?6,""NAME"""
133 Q
134PRMPT2 ;-----Yes and No prompt if only one choice
135 D WIN17^PXBCC(PXBCNT)
136 D LOC^PXBCC(15,1)
137 S DIR("A")="Is this the correct entry "
138 S DIR("B")="YES"
139 S DIR(0)="Y"
140 D ^DIR
141 I Y=0 S X="^"
142 I Y=1 S X=1
143 G VAL
144 ;
Note: See TracBrowser for help on using the repository browser.