- PRSEUTL4 ;HISC/MD-CLASS ASSIGNMENT TO MANDATORY TRAINING GROUP ;2/22/94
- ;;4.0;PAID;**20**;Sep 21, 1995
- EN1 ; ADD CLASS TO MANDATORY TRAINING GROUP FROM PRSEE-CLS-INF
- N DA,Y,X I '$D(^PRSE(452.3,"B")) W !?3,"MANDATORY TRAINING (MI) GROUP FILE NOT PRESENT CANNOT CONTINUE!",! Q
- 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
- I $G(PRSW) S DIR(0)="E" D ^DIR Q:$G(DIRUT)
- ; W @IOF,"This class may be assigned to the following Mandatory Training Gps."
- S:'+$P($G(^PRSE(452.1,+PRSEMI,0)),U,9) PRSW(1)=1 S PSPC=+$G(PRSESER) D DISP G:$G(POUT) QUIT
- ADD F PDA=0:0 S PDA=$O(^TMP("PRSEGRP",$J,PDA)) Q:PDA'>0 D
- . N DA,X,Y S X=$O(^PRSE(452.1,"B",PRSEPROG,0)),PRMI=$P($G(^PRSE(452.3,PDA,0)),U)
- . S:'$D(^PRSE(452.3,PDA,1,0)) ^(0)="^452.31P^^"
- . I $D(^PRSE(452.3,PDA,1,"B",X)) W !!,$C(7),"*** This class is already assigned to the "_PRMI_" training group. ***" Q
- . K DD,DO I '$D(^PRSE(452.3,PDA,1,"B",X)) D
- . . 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."
- . . Q
- . Q
- ; I '$G(POUT) W ! S DIR(0)="E" D ^DIR K DIR Q:Y'>0
- QUIT K PRSETAB,PRSE,PRSEAQ,PRSEND,DIC,PURP,PSVC,DLAYGO,I,PRSEMAX,NCTR,PDA,PRMI,PRSECLA,PRSECNT,PRSEI,PRSEMI,PRSVC,PRSW,PRX
- Q
- DISP ;
- K PRSETAB,PSVC S NCTR=1,PRSVC="",PRSEMAX=0
- 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
- . S HOSP=$O(^PRSP(454.1,"B","MISCELLANEOUS",0))
- . 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
- . . S PRSEMAX=PRSEMAX+1,PSVC(PRSEMAX)=DA_"^"_PRSVC
- . . Q
- . I $G(PRSESEL)="M",$P($G(^PRSE(452.3,+DA,0)),U,2)=HOSP D
- . . S PRSEMAX=PRSEMAX+1,PSVC(PRSEMAX)=DA_"^"_PRSVC
- . . Q
- . Q
- I '$O(PSVC(0)) W $C(7),!!,"No MANDATORY TRAINING GROUPS Found for this Service - NOTIFY PACKAGE COORDINATOR" S POUT=1 Q
- S PRSESTRT=1,(POUT,PRSEDONE)=0
- K ^TMP("PRSEGRP",$J) F D DSP I $G(PRSEDONE)!$G(POUT) Q
- S:'$O(^TMP("PRSEGRP",$J,0)) POUT=1 Q
- DSP ;
- W @IOF W:$D(PRSW) "This class may be assigned to the following mandatory Training Groups." S PRSEAQ=$Y
- F PRSE=PRSESTRT:2:PRSEMAX S PRSEI=PRSE D I $Y>(IOSL+PRSEAQ-5),PRSE'=PRSEMAX S PRSESTRT=PRSE+2 Q
- . Q:$D(PSVC(PRSEI))[0
- . 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)
- . Q
- S PRSEDONE=(PRSE=PRSEMAX)!(PRSE+1=PRSEMAX)
- I 'PRSEDONE W !,"<<More>>"
- ASK W !!,"Select TRAINING Group(s) to be "_$S($G(PRSEACT)="D":"deleted: ",1:"assigned: ") R PRX:DTIME
- S:'$T PRX="^" I "^"[PRX S:$E(PRX)="^" POUT=1 Q
- S PRSENALL=1 D VALENT^PRSEED7 K PRSENALL I (PRX["?"!(PRSEBAD)) G DSP:PRX?2."?",ASK
- 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))=""
- Q
- EN2(DA) ; USER SERVICE SELECTION ROUTINE WITH 200 FILE POINTER
- S (XXX,PDA,PRSEDATA)=""
- I $P($G(^PRSPC(DA,0)),U,9)?9N S PRSEDATA=$P(^(0),U,9)
- 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))
- 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)
- K PRSEDATA
- Q XXX
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSEUTL4 3770 printed Mar 13, 2025@21:31:57 Page 2
- PRSEUTL4 ;HISC/MD-CLASS ASSIGNMENT TO MANDATORY TRAINING GROUP ;2/22/94
- +1 ;;4.0;PAID;**20**;Sep 21, 1995
- EN1 ; ADD CLASS TO MANDATORY TRAINING GROUP FROM PRSEE-CLS-INF
- +1 NEW DA,Y,X
- IF '$DATA(^PRSE(452.3,"B"))
- WRITE !?3,"MANDATORY TRAINING (MI) GROUP FILE NOT PRESENT CANNOT CONTINUE!",!
- QUIT
- +2 SET PRSW=0
- FOR PDA=0:0
- SET PDA=$ORDER(^PRSE(452.3,"C",PDA))
- if PDA'>0
- QUIT
- IF $DATA(^PRSE(452.3,"C",PDA,PRSEMI))
- if '(+PRSW>0)
- WRITE !!,"This class is assigned to the following Mandatory Training Group(s): "
- WRITE !,$PIECE($GET(^PRSE(452.3,PDA,0)),U)
- SET PRSW=1
- +3 IF $GET(PRSW)
- SET DIR(0)="E"
- DO ^DIR
- if $GET(DIRUT)
- QUIT
- +4 ; W @IOF,"This class may be assigned to the following Mandatory Training Gps."
- +5 if '+$PIECE($GET(^PRSE(452.1,+PRSEMI,0)),U,9)
- SET PRSW(1)=1
- SET PSPC=+$GET(PRSESER)
- DO DISP
- if $GET(POUT)
- GOTO QUIT
- ADD FOR PDA=0:0
- SET PDA=$ORDER(^TMP("PRSEGRP",$JOB,PDA))
- if PDA'>0
- QUIT
- Begin DoDot:1
- +1 NEW DA,X,Y
- SET X=$ORDER(^PRSE(452.1,"B",PRSEPROG,0))
- SET PRMI=$PIECE($GET(^PRSE(452.3,PDA,0)),U)
- +2 if '$DATA(^PRSE(452.3,PDA,1,0))
- SET ^(0)="^452.31P^^"
- +3 IF $DATA(^PRSE(452.3,PDA,1,"B",X))
- WRITE !!,$CHAR(7),"*** This class is already assigned to the "_PRMI_" training group. ***"
- QUIT
- +4 KILL DD,DO
- IF '$DATA(^PRSE(452.3,PDA,1,"B",X))
- Begin DoDot:2
- +5 SET DA(1)=PDA
- SET DLAYGO=452.31
- SET DIC="^PRSE(452.3,DA(1),1,"
- SET DIC(0)="L"
- DO FILE^DICN
- SET DIK=DIC
- SET DIK(1)=".01^B^C^D"
- DO ENALL^DIK
- KILL DIC,DIK
- DO EN2^PRSEUTL5(PDA)
- WRITE !!,"This class has been added to the "_PRMI_" MI review group."
- +6 QUIT
- End DoDot:2
- +7 QUIT
- End DoDot:1
- +8 ; I '$G(POUT) W ! S DIR(0)="E" D ^DIR K DIR Q:Y'>0
- QUIT KILL PRSETAB,PRSE,PRSEAQ,PRSEND,DIC,PURP,PSVC,DLAYGO,I,PRSEMAX,NCTR,PDA,PRMI,PRSECLA,PRSECNT,PRSEI,PRSEMI,PRSVC,PRSW,PRX
- +1 QUIT
- DISP ;
- +1 KILL PRSETAB,PSVC
- SET NCTR=1
- SET PRSVC=""
- SET PRSEMAX=0
- +2 ;I $O(^PRSE(452.3,+DA,1,0))>0 D
- FOR I=1:1
- SET PRSVC=$ORDER(^PRSE(452.3,"B",PRSVC))
- if PRSVC=""
- QUIT
- FOR DA=0:0
- SET DA=$ORDER(^PRSE(452.3,"B",PRSVC,DA))
- if DA'>0
- QUIT
- Begin DoDot:1
- +3 SET HOSP=$ORDER(^PRSP(454.1,"B","MISCELLANEOUS",0))
- +4 IF '($GET(PRSESEL)="M")
- IF (+$$EN4^PRSEUTL3($GET(DUZ))!(DUZ(0)["@"!($PIECE($GET(^PRSE(452.3,+DA,0)),U,2)=PSPC!($PIECE($GET(^(0)),U,2)=HOSP!(+$GET(PRSW(1)))))))
- Begin DoDot:2
- +5 SET PRSEMAX=PRSEMAX+1
- SET PSVC(PRSEMAX)=DA_"^"_PRSVC
- +6 QUIT
- End DoDot:2
- +7 IF $GET(PRSESEL)="M"
- IF $PIECE($GET(^PRSE(452.3,+DA,0)),U,2)=HOSP
- Begin DoDot:2
- +8 SET PRSEMAX=PRSEMAX+1
- SET PSVC(PRSEMAX)=DA_"^"_PRSVC
- +9 QUIT
- End DoDot:2
- +10 QUIT
- End DoDot:1
- +11 IF '$ORDER(PSVC(0))
- WRITE $CHAR(7),!!,"No MANDATORY TRAINING GROUPS Found for this Service - NOTIFY PACKAGE COORDINATOR"
- SET POUT=1
- QUIT
- +12 SET PRSESTRT=1
- SET (POUT,PRSEDONE)=0
- +13 KILL ^TMP("PRSEGRP",$JOB)
- FOR
- DO DSP
- IF $GET(PRSEDONE)!$GET(POUT)
- QUIT
- +14 if '$ORDER(^TMP("PRSEGRP",$JOB,0))
- SET POUT=1
- QUIT
- DSP ;
- +1 WRITE @IOF
- if $DATA(PRSW)
- WRITE "This class may be assigned to the following mandatory Training Groups."
- SET PRSEAQ=$Y
- +2 FOR PRSE=PRSESTRT:2:PRSEMAX
- SET PRSEI=PRSE
- Begin DoDot:1
- +3 if $DATA(PSVC(PRSEI))[0
- QUIT
- +4 SET PRSEI(0)=PRSEI+1
- WRITE !
- if $GET(PSVC(PRSEI))'=""
- WRITE ?1,$JUSTIFY(PRSEI,2),". ",$PIECE($GET(PSVC(PRSEI)),U,2)
- if $GET(PSVC(PRSEI(0)))'=""
- WRITE ?40,$JUSTIFY(PRSEI(0),2),". ",$PIECE($GET(PSVC(PRSEI(0))),U,2)
- +5 QUIT
- End DoDot:1
- IF $Y>(IOSL+PRSEAQ-5)
- IF PRSE'=PRSEMAX
- SET PRSESTRT=PRSE+2
- QUIT
- +6 SET PRSEDONE=(PRSE=PRSEMAX)!(PRSE+1=PRSEMAX)
- +7 IF 'PRSEDONE
- WRITE !,"<<More>>"
- ASK WRITE !!,"Select TRAINING Group(s) to be "_$SELECT($GET(PRSEACT)="D":"deleted: ",1:"assigned: ")
- READ PRX:DTIME
- +1 if '$TEST
- SET PRX="^"
- IF "^"[PRX
- if $EXTRACT(PRX)="^"
- SET POUT=1
- QUIT
- +2 SET PRSENALL=1
- DO VALENT^PRSEED7
- KILL PRSENALL
- IF (PRX["?"!(PRSEBAD))
- if PRX?2."?"
- GOTO DSP
- GOTO ASK
- +3 FOR PRSEI=1:1
- SET PRSECLA=$PIECE(PRX,",",PRSEI)
- if PRSECLA=""
- QUIT
- SET PRSEND=$PIECE(PRSECLA,"-",2)_"+"_PRSECLA
- FOR PRSECNT=+PRSECLA:1:PRSEND
- IF +$GET(PSVC(PRSECNT))>0
- SET ^TMP("PRSEGRP",$JOB,+PSVC(PRSECNT))=""
- +4 QUIT
- EN2(DA) ; USER SERVICE SELECTION ROUTINE WITH 200 FILE POINTER
- +1 SET (XXX,PDA,PRSEDATA)=""
- +2 IF $PIECE($GET(^PRSPC(DA,0)),U,9)?9N
- SET PRSEDATA=$PIECE(^(0),U,9)
- +3 IF PRSEDATA>0
- SET $PIECE(PRSEDATA,U,2)=$PIECE(^PRSPC(+DA,0),U,49)
- IF $PIECE(PRSEDATA,U,2)>0
- SET $PIECE(PRSEDATA,U,3)=$ORDER(^PRSP(454,1,"ORG","B",$EXTRACT($PIECE(PRSEDATA,U,2),1,4)_":"_$EXTRACT($PIECE(PRSEDATA,U,2),5,8),0))
- +4 IF +$PIECE(PRSEDATA,U,3)>0
- SET $PIECE(PRSEDATA,U,4)=+$PIECE(^PRSP(454,1,"ORG",+$PIECE(PRSEDATA,U,3),0),U,2)
- SET XXX=$PIECE($GET(^PRSP(454.1,+$PIECE(PRSEDATA,U,4),0)),U)
- +5 KILL PRSEDATA
- +6 QUIT XXX
