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

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

initial load of WorldVistAEHR

File size: 3.0 KB
RevLine 
[613]1PXSCH2 ;ISL/JVS - SCHEDULING REDESIGN PROCEDURES-CPT #2 ;7/25/96 09:12
2 ;;1.0;PCE PATIENT CARE ENCOUNTER;**73**;Aug 12, 1996
3 ; Variable List
4 ;
5 ; CPTNOD0 The data for the ^TMP("PXK",$J, globals
6 ; CPTNOD12 The data for the ^TMP("PXK",$J, globals
7 ; CPTNOD8 The data for the ^TMP("PXK",$J, globals
8 ; PXSCPT Pointer to the precedure being processed
9 ; PXSCPTQ Quantity of the above procedure
10 ; PXSDX The main Diagnosis
11 ; PXSINDX Index for the "PXK" global
12 ; PXSPNN resolved provider narrative
13 ; PXSPNN(1) "" "" ""
14 ; PXSPR The main Provider
15 ; XP,XPFG Scratch Variables
16 ;
17SET ;Set the TMP("PXK",$J, GLOBAL
18CPT ;Create nodes for Procedures
19 S PXSCPT=0 F S PXSCPT=$O(PXS("PROC",PXSCPT)) Q:PXSCPT="" D
20 .S PXSINDX=PXSINDX+1
21 .S PXSCPTQ=$G(PXS("PROC",PXSCPT))
22 .D CPTNOD
23 Q
24CPTNOD ;
25 S CPTNOD0="",$P(CPTNOD0,"^")=$G(PXSCPT)
26 S $P(CPTNOD0,"^",2)=$G(PXS("PATIENT")) ;PATIENT
27 S $P(CPTNOD0,"^",3)=$G(PXS("VISIT")) ;VISIT
28 S PXSFILE=9000010.18
29 K ^UTILITY("DIQ1",$J)
30 S DIC=81,DA=PXSCPT,DR=2 D EN^DIQ1
31 S PXSZPN=$G(^UTILITY("DIQ1",$J,81,DA,2))
32 K ^UTILITY("DIQ1",$J),DIC,DA,DR
33 S $P(CPTNOD0,"^",4)=+$$PROVNARR^PXAPI(PXSZPN,PXSFILE) ;PROVIDER NARR
34 Q:$P(CPTNOD0,"^",4)=-1
35 ;S $P(CPTNOD0,"^",5)=$G(PXSDX) ;DIAGNOSIS
36 S $P(CPTNOD0,"^",16)=$G(PXSCPTQ) ;QUANTITY
37 S CPTNOD12=""
38 ;S $P(CPTNOD12,"^")=$G(PXS("DATE")) ;DATE AND TIME
39 ;S $P(CPTNOD12,"^",3)=$G(PXS("STOP CODE ORIG")) ;CLINIC STOP
40 ;S $P(CPTNOD12,"^",4)=$G(PXSPR) ;PROVIDER
41 ;S $P(CPTNOD12,"^",5)=$G(PXS("CLINIC")) ;HOSPITAL LOCATION
42 ;S $P(CPTNOD12,"^",7)=$P(CPTNOD0,"^",3) ;SECONDARY VISIT
43 ;--DECIDED TO REMOVE THE CATEGORY
44 ;S CPTNOD8=""
45 ;K ^UTILITY("DIQ1",$J) S DIC=81,DA=PXSCPT,DR=3,DIQ(0)="EIN" D EN^DIQ1
46 ;I $G(^UTILITY("DIQ1",$J,81,DA,3,"I")) D
47 ;.S PXSZPN=$G(^UTILITY("DIQ1",$J,81,DA,3,"E"))
48 ;.S CPTNOD8=+$$PROVNARR^PXAPI(PXSZPN,PXSFILE)
49 ;.I CPTNOD8'>0 S CPTNOD8=""
50 ;K ^UTILITY("DIQ1",$J),DIC,DA,DR,DIQ
51 S ^TMP("PXK",$J,"CPT",PXSINDX+1,0,"AFTER")=$G(CPTNOD0)
52 S ^TMP("PXK",$J,"CPT",PXSINDX+1,0,"BEFORE")=""
53 S ^TMP("PXK",$J,"CPT",PXSINDX+1,1,1,"BEFORE")=""
54 S ^TMP("PXK",$J,"CPT",PXSINDX+1,12,"AFTER")=$G(CPTNOD12)
55 S ^TMP("PXK",$J,"CPT",PXSINDX+1,12,"BEFORE")=""
56 S ^TMP("PXK",$J,"CPT",PXSINDX+1,802,"AFTER")=""
57 S ^TMP("PXK",$J,"CPT",PXSINDX+1,802,"BEFORE")=""
58 S ^TMP("PXK",$J,"CPT",PXSINDX+1,"IEN")=""
59 S ^TMP("PXK",$J,"SOR")=8
60 S ^TMP("PXK",$J,"VST",1,"IEN")=$G(PXS("VISIT"))
61CPTDUP ;Look for duplicates on the same visit
62 N XPFG,XP,PXKSEQ,PXKMOD
63 S (XPFG,XP)=0
64 F Q:XPFG S XP=$O(^AUPNVCPT("AD",PXS("VISIT"),XP)) Q:XP="" D
65 .I $P(^AUPNVCPT(XP,0),"^",1)=PXSCPT D
66 ..S ^TMP("PXK",$J,"CPT",PXSINDX+1,0,"BEFORE")=$G(^AUPNVCPT(XP,0))
67 ..S PXKSEQ=0
68 ..F S PXKSEQ=$O(^AUPNVCPT(XP,1,PXKSEQ)) Q:'PXKSEQ D
69 ...S PXKMOD=^AUPNVCPT(XP,1,PXKSEQ,0)
70 ...S ^TMP("PXK",$J,"CPT",PXSINDX+1,1,PXKSEQ,"BEFORE")=PXKMOD
71 ..S ^TMP("PXK",$J,"CPT",PXSINDX+1,12,"BEFORE")=$G(^AUPNVCPT(XP,12))
72 ..S ^TMP("PXK",$J,"CPT",PXSINDX+1,802,"BEFORE")=+$G(^AUPNVCPT(XP,802))
73 ..S ^TMP("PXK",$J,"CPT",PXSINDX+1,"IEN")=XP
74 ..S XPFG=1
75 Q
Note: See TracBrowser for help on using the repository browser.