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

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

initial load of FOIAVistA 6/30/08 version
File size: 3.1 KB
Line 
1PXKMAIN2 ;ISL/JVS - Special Routine ;5/21/96 13:20
2 ;;1.0;PCE PATIENT CARE ENCOUNTER;**69,186**;Aug 12, 1996;Build 3
3 ; VARIABLES
4 ; See variables lists under each line tag
5 ;
6 ;
7SPEC ;Populate other v files
8 ; VARIABLES
9 ; PXKAV(0) = The AFTER variables created in PXKMAIN
10 ; PXKBV(0) = The BEFORE variables created in PXKMAIN
11 ; PXKFG(ED,DE,AD) =The EDIT,DELETE,ADD flags
12 ; PXKCAT = The category being $o through (CPT,IMM etc...)
13 ; PXKIN = The pointer value of first piece in the mapping file
14 ; PXKPXD = An array with all the entries to be mapped this go around
15 ; PXKDIEN = IEN of the coding file
16 ;
17 S PXKDONE=0
18 Q:PXKFGED=1
19 I (PXKFGAD=1) D
20 .I $D(^PXD(811.1,"AA",PXKAV(0,1),""_PXKCAT_"",1)) D
21 ..S PXKDONE=$O(^PXD(811.1,"AA",PXKAV(0,1),""_PXKCAT_"",1,PXKDONE))
22 ..S PXJ(1)=$G(^PXD(811.1,PXKDONE,0)) ;8TH IEN
23 ..S PXJ(2)=$P(PXJ(1),"^",2) ;SECOND PIECE OF 8TH IEN
24 ..S PXJ(3)=$P(PXJ(2),";",1) ;FIRST PIECE OF ABOVE
25 ..S PXJ(4)=$P(PXJ(1),"^",4) ;TO
26 ..S PXKDONE=$O(^PXD(811.1,"AA",PXJ(3),""_PXJ(4)_"",1,0))
27 ..S:PXKDONE="" PXKDONE=0 I '$D(PXKPXD($G(PXKDONE))) D POP
28 I (PXKFGDE=1) D
29 .I $D(^PXD(811.1,"AA",PXKBV(0,1),""_PXKCAT_"",1)) D
30 ..S PXKDONE=$O(^PXD(811.1,"AA",PXKBV(0,1),""_PXKCAT_"",1,PXKDONE))
31 ..S PXJ(1)=$G(^PXD(811.1,PXKDONE,0)) ;8TH IEN
32 ..S PXJ(2)=$P(PXJ(1),"^",2) ;SECOND PIECE OF 8TH IEN
33 ..S PXJ(3)=$P(PXJ(2),";",1) ;FIRST PIECE OF ABOVE
34 ..S PXJ(4)=$P(PXJ(1),"^",4) ;TO
35 ..S PXKDONE=$O(^PXD(811.1,"AA",PXJ(3),""_PXJ(4)_"",1,0))
36 ..S:PXKDONE="" PXKDONE=0 I '$D(PXKPXD($G(PXKDONE))) D POP
37 K PXKDONE
38 Q
39 ;
40POP ;Population of more than one v file using PCE CODE MAPPING file 811.1
41 ;
42 ;N PXKPXD
43 N PXKROU,PXKIN,PXKX,PXKXX,PXKDIEN,PXKTO
44 S PXKIN=$S(PXKFGAD=1:PXKAV(0,1),PXKFGDE=1:PXKBV(0,1),1:"")
45 S PXKDIEN=0 F S PXKDIEN=$O(^PXD(811.1,"AA",PXKIN,PXKCAT,1,PXKDIEN)) Q:PXKDIEN="" D
46 .S PXKPXD(PXKDIEN)=$G(^PXD(811.1,PXKDIEN,0))
47 S (PXKX,PXKXX)=0 F S PXKX=$O(PXKPXD(PXKX)) Q:PXKX="" S PXKXX=PXKXX+.01 D
48 .I TMPPX[("^"_PXKX_"^") Q
49 .S PXKTO=$P(PXKPXD(PXKX),"^",4)
50 .S PXKROU=$P(PXKPXD(PXKX),"^",3)_"^PXKF"_PXKTO_"1" D @PXKROU
51 .S TMPPX=TMPPX_PXKX_"^"
52 S PXKNORG("SOR")=$G(^TMP("PXK",$J,"SOR"))
53 S PXKNORG("VSTIEN")=$G(^TMP("PXK",$J,"VST",1,"IEN"))
54 Q
55 ;
56RECALL ; Recall PXKMAIN to populate special circumstances
57 D EVENT^PXKMAIN K ^TMP("PXK",$J)
58 S PXKREF="^TMP(""PXKSAVE"",$J)"
59 F S PXKREF=$Q(@PXKREF) Q:$P(PXKREF,",",1)'["PXKSAVE" Q:$P(PXKREF,",",2)'[$J Q:PXKREF="" S PXKSAVE=PXKREF D
60 .S $P(PXKSAVE,"""",2)="PXK" S @PXKSAVE=$G(@PXKREF)
61 S ^TMP("PXK",$J,"SOR")=$G(PXKNORG("SOR"))
62 S ^TMP("PXK",$J,"VST",1,"IEN")=$G(PXKNORG("VSTIEN"))
63 K ^TMP("PXKSAVE",$J),PXKNORG
64 D EN1^PXKMAIN,EVENT^PXKMAIN
65 Q
66 ;
67 ;
68PRVTYPE ;---POPULATE PROVIDER TYPE
69 ;
70 ;--**
71 I '$D(^TMP("PXK",$J,"PRV")) Q
72 I '$L($T(GET^XUA4A72)) Q
73 N PXKPSUB,PXKPRV,PXKDT,NOD0,TYPE
74 S PXKPSUB=0 F S PXKPSUB=$O(^TMP("PXK",$J,"PRV",PXKPSUB)) Q:PXKPSUB="" D
75 .S NOD0=$G(^TMP("PXK",$J,"PRV",PXKPSUB,0,"AFTER"))
76 .S PXKPRV=$P(NOD0,"^",1)
77 .I '$G(PXKPRV) Q
78 .S PXKDT=+$P($G(^AUPNVSIT($G(^TMP("PXK",$J,"VST",1,"IEN")),0)),"^",1)
79 .;--** ADD FUNCTION
80 .S TYPE=+$$GET^XUA4A72($G(PXKPRV),+$P($G(PXKDT),".")) Q:TYPE<1
81 .I $P(NOD0,"^",6)']"" S $P(NOD0,"^",6)=TYPE
82 .S ^TMP("PXK",$J,"PRV",PXKPSUB,0,"AFTER")=NOD0
83 Q
Note: See TracBrowser for help on using the repository browser.