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 Apr 09, 2024@21:28:08 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
