source: FOIAVistA/trunk/r/PAID-PRS/PRSEUTL4.m@ 1693

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

initial load of FOIAVistA 6/30/08 version

File size: 3.6 KB
Line 
1PRSEUTL4 ;HISC/MD-CLASS ASSIGNMENT TO MANDATORY TRAINING GROUP ;2/22/94
2 ;;4.0;PAID;**20**;Sep 21, 1995
3EN1 ; ADD CLASS TO MANDATORY TRAINING GROUP FROM PRSEE-CLS-INF
4 N DA,Y,X I '$D(^PRSE(452.3,"B")) W !?3,"MANDATORY TRAINING (MI) GROUP FILE NOT PRESENT CANNOT CONTINUE!",! Q
5 S PRSW=0 F PDA=0:0 S PDA=$O(^PRSE(452.3,"C",PDA)) Q:PDA'>0 I $D(^PRSE(452.3,"C",PDA,PRSEMI)) W:'(+PRSW>0) !!,"This class is assigned to the following Mandatory Training Group(s): " W !,$P($G(^PRSE(452.3,PDA,0)),U) S PRSW=1
6 I $G(PRSW) S DIR(0)="E" D ^DIR Q:$G(DIRUT)
7 ; W @IOF,"This class may be assigned to the following Mandatory Training Gps."
8 S:'+$P($G(^PRSE(452.1,+PRSEMI,0)),U,9) PRSW(1)=1 S PSPC=+$G(PRSESER) D DISP G:$G(POUT) QUIT
9ADD F PDA=0:0 S PDA=$O(^TMP("PRSEGRP",$J,PDA)) Q:PDA'>0 D
10 . N DA,X,Y S X=$O(^PRSE(452.1,"B",PRSEPROG,0)),PRMI=$P($G(^PRSE(452.3,PDA,0)),U)
11 . S:'$D(^PRSE(452.3,PDA,1,0)) ^(0)="^452.31P^^"
12 . I $D(^PRSE(452.3,PDA,1,"B",X)) W !!,$C(7),"*** This class is already assigned to the "_PRMI_" training group. ***" Q
13 . K DD,DO I '$D(^PRSE(452.3,PDA,1,"B",X)) D
14 . . S DA(1)=PDA,DLAYGO=452.31,DIC="^PRSE(452.3,DA(1),1,",DIC(0)="L" D FILE^DICN S DIK=DIC,DIK(1)=".01^B^C^D" D ENALL^DIK K DIC,DIK D EN2^PRSEUTL5(PDA) W !!,"This class has been added to the "_PRMI_" MI review group."
15 . . Q
16 . Q
17 ; I '$G(POUT) W ! S DIR(0)="E" D ^DIR K DIR Q:Y'>0
18QUIT K PRSETAB,PRSE,PRSEAQ,PRSEND,DIC,PURP,PSVC,DLAYGO,I,PRSEMAX,NCTR,PDA,PRMI,PRSECLA,PRSECNT,PRSEI,PRSEMI,PRSVC,PRSW,PRX
19 Q
20DISP ;
21 K PRSETAB,PSVC S NCTR=1,PRSVC="",PRSEMAX=0
22 F I=1:1 S PRSVC=$O(^PRSE(452.3,"B",PRSVC)) Q:PRSVC="" F DA=0:0 S DA=$O(^PRSE(452.3,"B",PRSVC,DA)) Q:DA'>0 D ;I $O(^PRSE(452.3,+DA,1,0))>0 D
23 . S HOSP=$O(^PRSP(454.1,"B","MISCELLANEOUS",0))
24 . I '($G(PRSESEL)="M"),(+$$EN4^PRSEUTL3($G(DUZ))!(DUZ(0)["@"!($P($G(^PRSE(452.3,+DA,0)),U,2)=PSPC!($P($G(^(0)),U,2)=HOSP!(+$G(PRSW(1))))))) D
25 . . S PRSEMAX=PRSEMAX+1,PSVC(PRSEMAX)=DA_"^"_PRSVC
26 . . Q
27 . I $G(PRSESEL)="M",$P($G(^PRSE(452.3,+DA,0)),U,2)=HOSP D
28 . . S PRSEMAX=PRSEMAX+1,PSVC(PRSEMAX)=DA_"^"_PRSVC
29 . . Q
30 . Q
31 I '$O(PSVC(0)) W $C(7),!!,"No MANDATORY TRAINING GROUPS Found for this Service - NOTIFY PACKAGE COORDINATOR" S POUT=1 Q
32 S PRSESTRT=1,(POUT,PRSEDONE)=0
33 K ^TMP("PRSEGRP",$J) F D DSP I $G(PRSEDONE)!$G(POUT) Q
34 S:'$O(^TMP("PRSEGRP",$J,0)) POUT=1 Q
35DSP ;
36 W @IOF W:$D(PRSW) "This class may be assigned to the following mandatory Training Groups." S PRSEAQ=$Y
37 F PRSE=PRSESTRT:2:PRSEMAX S PRSEI=PRSE D I $Y>(IOSL+PRSEAQ-5),PRSE'=PRSEMAX S PRSESTRT=PRSE+2 Q
38 . Q:$D(PSVC(PRSEI))[0
39 . S PRSEI(0)=PRSEI+1 W ! W:$G(PSVC(PRSEI))'="" ?1,$J(PRSEI,2),". ",$P($G(PSVC(PRSEI)),U,2) W:$G(PSVC(PRSEI(0)))'="" ?40,$J(PRSEI(0),2),". ",$P($G(PSVC(PRSEI(0))),U,2)
40 . Q
41 S PRSEDONE=(PRSE=PRSEMAX)!(PRSE+1=PRSEMAX)
42 I 'PRSEDONE W !,"<<More>>"
43ASK W !!,"Select TRAINING Group(s) to be "_$S($G(PRSEACT)="D":"deleted: ",1:"assigned: ") R PRX:DTIME
44 S:'$T PRX="^" I "^"[PRX S:$E(PRX)="^" POUT=1 Q
45 S PRSENALL=1 D VALENT^PRSEED7 K PRSENALL I (PRX["?"!(PRSEBAD)) G DSP:PRX?2."?",ASK
46 F PRSEI=1:1 S PRSECLA=$P(PRX,",",PRSEI) Q:PRSECLA="" S PRSEND=$P(PRSECLA,"-",2)_"+"_PRSECLA F PRSECNT=+PRSECLA:1:PRSEND I +$G(PSVC(PRSECNT))>0 S ^TMP("PRSEGRP",$J,+PSVC(PRSECNT))=""
47 Q
48EN2(DA) ; USER SERVICE SELECTION ROUTINE WITH 200 FILE POINTER
49 S (XXX,PDA,PRSEDATA)=""
50 I $P($G(^PRSPC(DA,0)),U,9)?9N S PRSEDATA=$P(^(0),U,9)
51 I PRSEDATA>0 S $P(PRSEDATA,U,2)=$P(^PRSPC(+DA,0),U,49) I $P(PRSEDATA,U,2)>0 S $P(PRSEDATA,U,3)=$O(^PRSP(454,1,"ORG","B",$E($P(PRSEDATA,U,2),1,4)_":"_$E($P(PRSEDATA,U,2),5,8),0))
52 I +$P(PRSEDATA,U,3)>0 S $P(PRSEDATA,U,4)=+$P(^PRSP(454,1,"ORG",+$P(PRSEDATA,U,3),0),U,2),XXX=$P($G(^PRSP(454.1,+$P(PRSEDATA,U,4),0)),U)
53 K PRSEDATA
54 Q XXX
Note: See TracBrowser for help on using the repository browser.