source: WorldVistAEHR/trunk/r/PCE_PATIENT_CARE_ENCOUNTER-AUTN-EFDP-PX-VSIT--PXRM/PXKFCPT1.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: 4.1 KB
Line 
1PXKFCPT1 ;ISL/JVS - PROCEDURES Routine #2 ;2/11/04 4:18pm
2 ;;1.0;PCE PATIENT CARE ENCOUNTER;**11,73,124**;Aug 12, 1996
3 ;
4 ;
5IMM ;
6 N PXKSEQ1
7 I PXKFGAD=1 D IMMADD
8 I PXKFGDE=1 D IMMDEL
9 Q
10IMMADD ;
11 S PXKKK=""
12 S PXKSEQ1=PXKSEQ+PXKXX
13 S PXKCPT=$P($P(PXKPXD(PXKX),"^",2),";")
14POVNAR ;
15 K ^UTILITY("DIQ1",$J)
16 S DIC=81,DA=PXKCPT,DR=2 D EN^DIQ1
17 S PXKCPTN=$G(^UTILITY("DIQ1",$J,81,DA,2))
18 K ^UTILITY("DIQ1",$J),DIC,DA,DR D
19 .Q:PXKCPTN="" I $D(^AUTNPOV("B",PXKCPTN)) S PXKCPTN=$O(^AUTNPOV("B",PXKCPTN,0))
20 ;
21QUANTIT S PXKQUN=1,PXSTOP=0
22 S PXXX=0
23 F S PXXX=$O(^AUPNVCPT("AD",PXKAV(0,3),PXXX)) Q:PXXX="" D Q:$G(PXSTOP)
24 .I +$P(^AUPNVCPT(PXXX,0),"^")=PXKCPT D
25 ..S PXKQUN=($P(^AUPNVCPT(PXXX,0),"^",16)+1)
26 ..S PXSTOP=1
27 ..S PXKKK=PXXX
28 ..S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,0,"BEFORE")=$G(^AUPNVCPT(PXXX,0))
29 K PXSTOP
30CATEGOR ;
31 N PXKSEQ2
32 S PXKCPTT(1)=$P(PXKCPT,"^",1)
33 K ^UTILITY("DIQ1",$J)
34 S DIC=81,DA=PXKCPTT(1),DR=3 D EN^DIQ1
35 Q:$G(^UTILITY("DIQ1",$J,81,DA,3))=""
36 S PXKCPTT(4.1)=$G(^UTILITY("DIQ1",$J,81,DA,3))
37 S PXKCPTT(5)=$E(PXKCPTT(4.1),1,30)
38 S PXKCPTT(6)=$O(^AUTNPOV("B",PXKCPTT(5),0))
39 S PXKPCA=$S(PXKCPTT(6)="":PXKCPTT(5),PXKCPTT(6)'="":PXKCPTT(6),1:"")
40 K PXKCPTT,^UTILITY("DIQ1",$J),DIC,DR,DA
41 ;PX*1*124
42 S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,0,"AFTER")=$G(PXKCPT)_"^"_$G(PXKAV(0,2))_"^"_$G(PXKAV(0,3))_"^"_$G(PXKCPTN)_"^"_$G(PXKAV(0,8))_"^^^^"
43 S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,0,"AFTER")=^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,0,"AFTER")_$G(PXKAV(0,9))_"^"_$G(PXKAV(0,10))_"^"_$G(PXKAV(0,11))_"^"_$G(PXKAV(0,12))_"^"_$G(PXKAV(0,13))_"^"_$G(PXKAV(0,14))_"^"_$G(PXKAV(0,15))_"^"_$G(PXKQUN)
44 S PXKSEQ2=0
45 F S PXKSEQ2=$O(PXKAFT(1,PXKSEQ2)) Q:'PXKSEQ2 D
46 .S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,1,PXKSEQ2,"AFTER")=PXKAFT(1,PXKSEQ2)
47 S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,12,"AFTER")=$G(PXKAFT(12))
48 S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,802,"AFTER")=$G(PXKCA)
49 S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,812,"AFTER")=$G(PXKAFT(812))
50 S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,"IEN")=PXKKK
51 K PXKQUN,PXKCPTN,PXKCA,PXXX,PXKKK
52 Q
53IMMDEL ;Retrieve all CPT information for VISIT from V CPT file
54 S PXKSEQ1=PXKSEQ+PXKXX
55 S (XPFG,XP)=0 F Q:XPFG S XP=$O(^AUPNVCPT("AD",PXKVST,XP)) Q:XP="" D
56 .I $P(^AUPNVCPT(XP,0),"^",1)=$P($P(PXKPXD(PXKX),"^",2),";") D S XPFG=1
57 ..I $P($G(^AUPNVCPT(XP,0)),"^",16)=1 D IMMDEL1
58 ..I $D(XP),$P($G(^AUPNVCPT(XP,0)),"^",16)>1 D IMMDEL2
59 Q
60IMMDEL1 ;
61 N PXKSEQ2,PXKMOD
62 S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,0,"BEFORE")=$G(^AUPNVCPT(XP,0))
63 S PXKSEQ2=0
64 F S PXKSEQ2=$O(^AUPNVCPT(XP,1,PXKSEQ2)) Q:'PXKSEQ2 D
65 .S PXKMOD=^AUPNVCPT(XP,1,PXKSEQ2,0)
66 .S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,1,PXKSEQ2,"BEFORE")=PXKMOD
67 S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,12,"BEFORE")=$G(^AUPNVCPT(XP,12))
68 S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,802,"BEFORE")=$G(^AUPNVCPT(XP,802))
69 S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,812,"BEFORE")=$G(^AUPNVCPT(XP,812))
70 S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,"IEN")=XP
71 S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,0,"AFTER")="@"
72 S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,12,"AFTER")=""
73 S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,802,"AFTER")=""
74 S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,812,"AFTER")=""
75 K XPFG,XP
76 Q
77IMMDEL2 ;
78 N PXKSEQ2,PXKMOD
79 S PXTEMP=$P($G(^AUPNVCPT(XP,0)),"^",16)
80 S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,0,"BEFORE")=$G(^AUPNVCPT(XP,0))
81 S PXKSEQ2=0
82 F S PXKSEQ2=$O(^AUPNVCPT(XP,1,PXKSEQ2)) Q:'PXKSEQ2 D
83 .S PXKMOD=^AUPNVCPT(XP,1,PXKSEQ2,0)
84 .S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,1,PXKSEQ2,"BEFORE")=PXKMOD
85 S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,12,"BEFORE")=$G(^AUPNVCPT(XP,12))
86 S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,802,"BEFORE")=$G(^AUPNVCPT(XP,802))
87 S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,812,"BEFORE")=$G(^AUPNVCPT(XP,812))
88 S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,"IEN")=XP
89 S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,0,"AFTER")=$G(^AUPNVCPT(XP,0))
90 S PXKSEQ2=0
91 F S PXKSEQ2=$O(^AUPNVCPT(XP,1,PXKSEQ2)) Q:'PXKSEQ2 D
92 .S PXKMOD=^AUPNVCPT(XP,1,PXKSEQ2,0)
93 .S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,1,PXKSEQ2,"BEFORE")=PXKMOD
94 S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,12,"AFTER")=$G(^AUPNVCPT(XP,12))
95 S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,802,"AFTER")=$G(^AUPNVCPT(XP,802))
96 S ^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,812,"AFTER")=$G(^AUPNVCPT(XP,812))
97 S $P(^TMP("PXKSAVE",$J,"CPT",PXKSEQ1,0,"AFTER"),"^",16)=((PXTEMP)-(1))
98 K XPFG,XP,PXTEMP
99 Q
100SK ;--START OF SKIN TEST
101 D IMM
102 Q
Note: See TracBrowser for help on using the repository browser.