source: FOIAVistA/trunk/r/PCE_PATIENT_CARE_ENCOUNTER-AUTN-EFDP-PX-VSIT--PXRM/PXBGSTP.m@ 1783

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

initial load of FOIAVistA 6/30/08 version

File size: 1.9 KB
Line 
1PXBGSTP ;ISL/JVS - GATHER STOP CODES FROM SECONDARY VISITS ;7/24/96 08:15
2 ;;1.0;PCE PATIENT CARE ENCOUNTER;;Aug 12, 1996
3 ;
4 ;
5 ;
6STP(PXBVST) ;--Gather the stop codes from the secondary visits
7 ;
8 ;
9 ;PXBVST=PRIMARY VISIT
10 ;--Validate A primary visit is sent in
11 I $P($G(^AUPNVSIT(PXBVST,150)),"^",3)'="P" S PXBCNT=0 Q
12 ;
13 ;--NEW variables
14 N IEN,STP,STOPCODE,AMISCODE,INDATEI,INDATEE,PXBC
15 N D0,D1,DA,DDH,DIG,DIH,DIQ,DR
16 ;--KILL variables
17 K ^TMP("PXBU",$J),VAUGHN,PXBKY,PXBSAM,PXBSKY,GROUP
18 ;--CREATE tmp global
19 I $D(^AUPNVSIT("AD",PXBVST)) D
20 .S IEN=0 F S IEN=$O(^AUPNVSIT("AD",PXBVST,IEN)) Q:IEN'>0 D
21 ..I '$P(^AUPNVSIT(IEN,0),"^",8) Q
22 ..I $P(^AUPNVSIT(IEN,150),"^",3)="C" Q
23 ..S ^TMP("PXBU",$J,"STP",IEN)=""
24 ;
25 ;
26A ;--Set array with the STOP CODES from the visits
27 I $D(^TMP("PXBU",$J,"STP")) D
28 .S IEN=0 F S IEN=$O(^TMP("PXBU",$J,"STP",IEN)) Q:IEN'>0 D
29 ..S DIC=9000010,DR=.08,DA=IEN,DIQ="VAUGHN(",DIQ(0)="EI" D EN^DIQ1
30 ..S STOPCODE=$G(VAUGHN(9000010,DA,.08,"E"))
31 ..S STOPIEN=$G(VAUGHN(9000010,DA,.08,"I"))
32 ..S DIC=40.7,DR="1;2",DA=STOPIEN,DIQ="VAUGHN(",DIQ(0)="EI" D EN^DIQ1
33 ..S AMISCODE=$G(VAUGHN(40.7,DA,1,"E"))
34 ..I $G(AMISCODE)']"" Q
35 ..S INDATEI=$G(VAUGHN(40.7,DA,2,"I"))
36 ..S INDATEE=$G(VAUGHN(40.7,DA,2,"E"))
37 ..S GROUP=AMISCODE_"^"_STOPCODE_"^"_INDATEI_"^"_INDATEE
38 ..S STP(AMISCODE,IEN)=GROUP
39 ;
40 ;
41B ;--ADD Line Numbers
42 I $D(STP) D
43 .S PXBC=0,STP="" F S STP=$O(STP(STP)) Q:STP="" D
44 ..S IEN=0 F S IEN=$O(STP(STP,IEN)) Q:IEN="" S PXBC=PXBC+1 D
45 ...S PXBKY(STP,PXBC)=$G(STP(STP,IEN)),PXBSAM(PXBC)=$G(STP(STP,IEN))
46 ...S PXBSKY(PXBC,IEN)=""
47F ;--FINISH UP THE VARIABLES
48 K ^TMP("PXBU",$J),VAUGHN
49 S PXBCNT=+$G(PXBC)
50CREDIT ;--FIND THE MAIN CREDIT STOP FROM MAIN VISIT
51 N CLIPTR,TANA,CRESTP
52 S CLIPTR=$P($G(^AUPNVSIT(PXBVST,0)),"^",22) Q:CLIPTR']""
53 S CRESTP=$P($G(^SC(CLIPTR,0)),"^",7) Q:CRESTP']""
54 ;
55 ;
56 S DIC=40.7,DR=".01;1",DA=CRESTP,DIQ="TANA(",DIQ(0)="EI" D EN^DIQ1
57 S CREDIT=TANA(40.7,CRESTP,1,"E")_"--"_TANA(40.7,CRESTP,.01,"E")
58 Q
59 ;
Note: See TracBrowser for help on using the repository browser.