source: WorldVistAEHR/trunk/r/PAID-PRS/PRSEUTL5.m@ 701

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

initial load of WorldVistAEHR

File size: 3.3 KB
RevLine 
[613]1PRSEUTL5 ;HISC/DAD-UPDATE MANDATORY CLASS MULT FROM MI REVIEW GROUP MULT ;3/23/94
2 ;;4.0;PAID;;Sep 21, 1995
3EN1(PRSED0) ; PRSED0 = IEN of an entry in file #450
4 ; Update MANDATORY CLASS multiple for an individual
5 N D0,D1,DA,DD,DIC,DIDEL,DIE,DIK,DINUM,DLAYGO,DO,DR
6 N PRSE,PRSECD0,PRSECLAS,PRSECNT,PRSED1,PRSEDTAS,PRSEGD0,PRSEGD1,X,Y
7 S PRSED1=0
8 F S PRSED1=$O(^PRSPC(PRSED0,5,PRSED1)) Q:PRSED1'>0 D
9 . S PRSE=$G(^PRSPC(PRSED0,5,PRSED1,0))
10 . S PRSEGD0=+$P(PRSE,"^"),PRSEDTAS=$P(PRSE,"^",2) Q:PRSEGD0'>0
11 . S PRSEGD1=0
12 . F S PRSEGD1=$O(^PRSE(452.3,PRSEGD0,1,PRSEGD1)) Q:PRSEGD1'>0 D
13 .. S PRSECD0=+$P($G(^PRSE(452.3,PRSEGD0,1,PRSEGD1,0)),"^") Q:PRSECD0'>0
14 .. S $P(PRSECLAS(PRSECD0),"^")=PRSEDTAS
15 .. S $P(PRSECLAS(PRSECD0),"^",2)=$P(PRSECLAS(PRSECD0),"^",2)+1
16 .. Q
17 . Q
18 D UPDATE
19 Q
20 ;
21EN2(PRSEGD0) ; PRSEGD0 = IEN of an entry in file #452.3
22 ; Update MANDATORY CLASS multiple for ALL individuals
23 ; with a selected MI REVIEW GROUP (*** TASKED ***)
24 N ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
25 S ZTRTN="EN21^PRSEUTL5",ZTSAVE("PRSEGD0")="",ZTDTH=$H,ZTIO=""
26 S ZTDESC="Education Tracking MANDATORY CLASS multiple update"
27 D ^%ZTLOAD
28 Q
29EN21 S PRSED0=0
30 F S PRSED0=$O(^PRSPC("ARG",PRSEGD0,PRSED0)) Q:PRSED0'>0 D EN1(PRSED0)
31 K PRSED0,PRSEGD0 S:$D(ZTQUEUED) ZTREQ="@"
32 Q
33 ;
34UPDATE S PRSED1=0
35 F S PRSED1=$O(^PRSPC(PRSED0,6,PRSED1)) Q:PRSED1'>0 D
36 . S PRSE=$G(^PRSPC(PRSED0,6,PRSED1,0))
37 . S PRSECD0=+$P(PRSE,"^"),PRSECNT=+$P(PRSE,"^",2) Q:PRSECD0'>0
38 . S PRSE=$G(PRSECLAS(PRSECD0))
39 . S PRSEDTAS=$P(PRSE,"^"),PRSECNT(0)=+$P(PRSE,"^",2)
40 . I PRSECNT=0,PRSECNT(0)=0 Q ; *** One-shot class
41 . I PRSECNT(0) D ; *** Update class count
42 .. K D0,D1,DA,DIE,DR S DIE="^PRSPC("_PRSED0_",6,"
43 .. S DR=".02///"_PRSECNT(0)_$S(PRSEDTAS:";.03///"_PRSEDTAS,1:"")
44 .. S (D0,DA(1))=PRSED0,(D1,DA)=PRSED1
45 .. I PRSECNT'=PRSECNT(0) D ^DIE
46 .. Q
47 . E D ; *** Delete class
48 .. K D0,D1,DA,DIK S DIK="^PRSPC("_PRSED0_",6,",DIDEL=450
49 .. S (D0,DA(1))=PRSED0,(D1,DA)=PRSED1 D ^DIK
50 .. Q
51 . K PRSECLAS(PRSECD0)
52 . Q
53 S PRSECD0=0 ; *** Add class
54 F S PRSECD0=$O(PRSECLAS(PRSECD0)) Q:PRSECD0'>0 D
55 . S PRSE=$G(PRSECLAS(PRSECD0))
56 . S PRSEDTAS=$P(PRSE,"^"),PRSECNT(0)=+$P(PRSE,"^",2) Q:PRSECNT(0)'>0
57 . K DD,DIC,DINUM,DO
58 . S DIC="^PRSPC("_PRSED0_",6,",DIC(0)="L",DLAYGO=450,X=PRSECD0
59 . S DIC("P")=$P(^DD(450,633,0),"^",2),(D0,DA(1))=PRSED0
60 . D FILE^DICN S PRSED1=+Y
61 . K D0,D1,DA,DIE,DR
62 . S DIE="^PRSPC("_PRSED0_",6,"
63 . S DR=".02///"_PRSECNT(0)_$S(PRSEDTAS:";.03///"_PRSEDTAS,1:"")
64 . S (D0,DA(1))=PRSED0,(D1,DA)=PRSED1 D ^DIE
65 . Q
66 K PRSECLAS
67 Q
68 ;
69EN3(PRSEGD0) ; PRSEGD0 = IEN in file 452.3
70 ; Used by ^DD(452.3,.01,"DEL",1,0) = "I $$EN3^PRSEUTL5(D0)"
71 I $O(^PRSPC("ARG",PRSEGD0,0)) D
72 . D EN^DDIOL(" This review group has employees assigned to it !!")
73 . Q
74 Q 0
75 ;
76EN4(PRSEGD0) ; PRSEGD0 = IEN in file #452.3
77 ; Used to delete review groups from individuals when the
78 ; review group itself is deleted. (*** TASKED ***)
79 S ZTRTN="EN41^PRSEUTL5",ZTSAVE("PRSEGD0")="",ZTDTH=$H,ZTIO=""
80 S ZTDESC="Education Tracking update MI REVIEW GROUP mult." D ^%ZTLOAD
81 Q
82 ;
83EN41 S PRSED0=0
84 F S PRSED0=$O(^PRSPC("ARG",PRSEGD0,PRSED0)) Q:PRSED0'>0 D
85 . S PRSED1=0
86 . F S PRSED1=$O(^PRSPC("ARG",PRSEGD0,PRSED0,PRSED1)) Q:PRSED1'>0 D
87 .. I $P($G(^PRSPC(PRSED0,5,PRSED1,0)),"^")'=PRSEGD0 Q
88 .. S DIK="^PRSPC("_PRSED0_",5,",(D0,DA(1))=PRSED0,(D1,DA)=PRSED1
89 .. D ^DIK
90 .. Q
91 . Q
92 S:$D(ZTQUEUED) ZTREQ="@"
93 Q
Note: See TracBrowser for help on using the repository browser.