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

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

initial load of WorldVistAEHR

File size: 3.7 KB
Line 
1PXBGPOV4 ;ISL/JVS - DOUBLE ?? GATHERING OF FORM DIAGNOSES ; 5/7/03 3:31pm
2 ;;1.0;PCE PATIENT CARE ENCOUNTER;**11,28,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,CODE,NAME,START,SCREEN,CNT,OK,INDEX,CYCLE
14 N TOTAL,PRV,CNT,PXBPMT,CODE,SUB2
15 ;---SETUP VARIABLES
16 S BACK="",INDEX=""
17 S START=DATA,SUB=0,SUB2=0
18 ;
19START1 ;--RECYCLE POINT
20 S TITLE="- - F O R M D I A G N O S I S - -"
21 ;
22 D GETLST^IBDF18A(CLINIC,$P($T(POV^PXBAICS),";;",2),"PXBPMT",,,,IDATE)
23ME ;
24 ;--------TEST PURPOSES-------
25 ;S PXBPMT(0)=4
26 ;S PXBPMT(1)="^TEST"
27 ;S PXBPMT(2)="309.0^TEST 1"
28 ;S PXBPMT(3)="295.12^TEST 2"
29 ;S PXBPMT(4)="V62.2^TEST 3"
30 ;---------------------
31 S TOTAL=PXBPMT(0)
32 I PXBPMT(0)>0 D
33 .S (SUB,CNT)=0 F S SUB=$O(PXBPMT(SUB)) Q:SUB="" D
34 ..Q:$P(PXBPMT(SUB),"^",1)=""
35 ..S CODE=$P(PXBPMT(SUB),"^",1)
36 ..;S Y=$O(^ICD9("AB",CODE_" ",0)) Q:Y=""
37 ..;I $P($G(^ICD9(Y,0)),"^",9)=1 Q
38 ..;I $P(^(0),"^",11)'=""&(IDATE>($P(^(0),"^",11))) Q
39 ..Q:'$P($$ICDDX^ICDCODE(DATA,IDATE),"^",10)
40 ..S NAME=$P(PXBPMT(SUB),"^",2)
41 ..S CNT=CNT+1
42 ..S ^TMP("PXBTOTAL",$J,"DILIST","ID",CNT,.01)=CODE
43 ..S ^TMP("PXBTOTAL",$J,"DILIST","ID",CNT,2)=NAME
44 I $D(CNT) S TOTAL=CNT
45 ;
46 ;
47 ;--DISPLAY IF NO MATCH FOUND
48 I TOTAL=0 W IOCUU,IOCUU,!,IOELEOL D
49 .D LOC W !
50 .S RESULTS="NO DIAGNOSIS BLOCKS EXIST FOR AN ENCOUNTER FORM" W !!!,?(IOM-$L(RESULTS))\2,RESULTS D HELP1^PXBUTL1("CON") R OK:DTIME
51 I TOTAL=0 Q TOTAL
52 ;
53 ;
54 ;----DISPLAY LIST TO THE SCREEN
55 S HEADING="W !,""ITEM"",?6,""CODE"",?13,""DESCRIPTION "",IOINHI,TOTAL,"" ENTRIES"",IOINLOW"
56LIST ;-DISPLAY LIST TO THE SCREEN
57 D LOC W !
58 X HEADING
59 S SUB=SUB-1
60 S NUM=0 F S SUB=$O(^TMP("PXBTOTAL",$J,"DILIST","ID",SUB)) S NUM=NUM+1 Q:NUM=11 Q:SUB'>0 S SUB2=SUB2+1 D
61 .S CODE=$G(^TMP("PXBTOTAL",$J,"DILIST","ID",SUB,.01))
62 .S NAME=$G(^TMP("PXBTOTAL",$J,"DILIST","ID",SUB,2))
63 .W !,SUB,?6,CODE,?13,NAME
64 ;
65 ;----If There is only one selection go to proper prompting
66 I TOTAL=1 G PRMPT2
67 ;
68PRMPT ;---WRITE PROMPT HERE
69 D WIN17^PXBCC(PXBCNT)
70 D LOC^PXBCC(15,1)
71 W !
72 I SUB>0 W !,"Enter '^' to quit"
73 E I TOTAL>10 W !," END OF LIST"
74 I SUB>0 S DIR("A")="Select a single 'ITEM NUMBER' or 'RETURN' to continue: "
75 E S DIR("A")="Select a single 'ITEM NUMBER' or 'RETURN' to exit: "
76 S DIR("?")="Enter ITEM 'No' to select , '^' to quit"
77 S DIR(0)="N,A,O^0:"_SUB2_":0^I X'?.1""^"".N K X"
78 D ^DIR
79 I X="",SUB>0 G LIST
80 I X="",SUB'>0 S X="^"
81 I $G(DIRUT) K DIRUT S VAL="^P" G EXITNEW
82VAL ;-----Set the VAL equal to the value
83 S VAL=$G(^TMP("PXBTOTAL",$J,"DILIST",2,X))_"^"_$G(^TMP("PXBTOTAL",$J,"DILIST","ID",X,.01))
84EXITNEW ;--EXIT
85 K DIR,^TMP("PXBTANA",$J),^TMP("PXBTOTAL",$J)
86 K TANA,TOTAL
87 Q VAL
88 Q
89 ;
90 ;-----------------SUBROUTINES--------------
91BACK ;
92 S START=$G(^TMP("PXBTANA",$J,"DILIST",1,1))
93 S START("IEN")=$G(^TMP("PXBTANA",$J,"DILIST",2,1))
94 Q
95FORWARD ;
96 S START=$G(^TMP("PXBTANA",$J,"DILIST",1,10))
97 S START("IEN")=$G(^TMP("PXBTANA",$J,"DILIST",2,10))
98 Q
99LOC ;--LOCATE CURSOR
100 D LOC^PXBCC(3,1) ;--LOCATE THE CURSOR
101 W IOEDEOP ;--CLEAR THE PAGE
102 Q
103HEAD ;--HEAD
104 W !,IOCUU,IOBON,"HELP SCREEN",IOSGR0,?(IOM-$L(TITLE))\2,IOINHI,TITLE,IOINLOW,IOELEOL
105 Q
106SUB ;--DISPLAY LIST TO THE SCREEN
107 I $P(^TMP("PXBTANA",$J,"DILIST",0),"^",1)=0 W !!," E N D O F L I S T" Q
108 X HEADING
109 S SUB=0,CNT=0 F S SUB=$O(^TMP("PXBTANA",$J,"DILIST","ID",SUB)) Q:SUB'>0 S CNT=CNT+1 D
110 .S NAME=$G(^TMP("PXBTANA",$J,"DILIST","ID",SUB,.01))
111 .W !,SUB,?6,NAME
112 Q
113SETUP ;-SETP VARIABLES
114 S FILE=200,FIELD=.01
115 S HEADING="W !,""ITEM"",?6,""NAME"""
116 Q
117PRMPT2 ;-----Yes and No prompt if onlyi choice
118 D WIN17^PXBCC(PXBCNT)
119 D LOC^PXBCC(15,1)
120 S DIR("A")="Is this the correct entry "
121 S DIR("B")="YES"
122 S DIR(0)="Y"
123 D ^DIR
124 I Y=0 S X="^"
125 I Y=1 S X=1
126 G VAL
Note: See TracBrowser for help on using the repository browser.