PRSEUTL ;HISC/JH/MD-EMPLOYEE EDUCATION REPORT - UTILITY ;4/24/1998
;;4.0;PAID;**13,25,32,41**;Sep 21, 1995
INS ; INSERVICE SELECTION
S DIR(0)="SO^M:Mandatory Training (MI);C:Continuing Education;O:Other/Miscellaneous;W:Ward/Unit-Location Training;A:All",DIR("A")="Select Sort Parameter"
D ^DIR K DIR I $D(DUOUT)!$D(DTOUT)!(U[X) S POUT=1 Q
S PRSESEL=Y
Q
INS2 ; INSERVICE SELECTION
S DIR(0)="SO^M:Mandatory Training (MI);C:Continuing Education;O:Other/Miscellaneous;W:Ward/Unit-Location Training;A:All;L:All without Mandatory;H:All without Hosptial Wide Mandatory"
S DIR("A")="Select Sort Parameter"
D ^DIR K DIR I $D(DUOUT)!$D(DTOUT)!(U[X) S POUT=1 Q
S PRSESEL=Y
Q
DATSEL ;
S DATSEL=U_$G(DATSEL)_U,DIR(0)="SO^C:Calendar Year;F:Fiscal Year;"
I DATSEL'["^NS^" S DIR(0)=DIR(0)_"S:Selected Date Range;"
S DIR("A")="Select a Sort Parameter"
D ^DIR K DIR I $D(DUOUT)!$D(DTOUT)!(U[X) S POUT=1 Q
S TYP=Y,YR=$E(DT,1,3)+1700 I TYP="F" S MN=$E(DT,4,5) S:MN>9 YR=(YR+1)
S DIR(0)="DA^^K:X'?4N X"
S X=YR D ^%DT D:+Y D^DIQ S DIR("B")=Y,DIR("?")="This response must be a year i.e. 1990"
I TYP["C" S DIR("A")="Select Calendar Year: " W ! D
.D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S POUT=1 Q
.S PYR=$G(Y(0)),YR(6)=$E($G(Y),1,3)+1700,%DT="",X=Y D ^%DT S YRST=+Y,%DT="",X="12/31/"_YR(6) D ^%DT S YREND=+Y_".24" K %DT S X1=YRST,X2=-90 D C^%DTC S YRCHK=X
I TYP["F" S DIR("A")="Select Fiscal Year: " W ! D
.D ^DIR S PYR=$G(Y(0)),YR(6)=$E(Y,1,3)+1700 K DIR I $D(DTOUT)!$D(DUOUT) S POUT=1 Q
.S %DT="",X="10/"_(YR(6)-1) D ^%DT S YRST=+Y S %DT="",X="9/30/"_YR(6) D ^%DT S YREND=+Y_".24" K %DT S X1=YRST,X2=-90 D C^%DTC S YRCHK=X
I TYP["S" K DIR D
.W ! S X=DT D ^%DT D:+Y D^DIQ S DIR("B")=Y,DIR(0)="DA^"_$S($D(PRSECAL):DT,1:"")_"::ET",DIR("A")="Start With DATE: ",DIR("?")="^S %DT(0)=$S($D(PRSECAL):DT,1:-DT) D HELP^%DTC"
.I DATSEL["^N+^" S DIR(0)="DA^:"_DT_":ET",DIR("?")="^S %DT(0)=-DT D HELP^%DTC"
.D ^DIR K %DT(0),DIR I $D(DTOUT)!$D(DUOUT)!(U[X) S POUT=1 Q
.S YRST=+Y,X=DT,%DT="T" D ^%DT D:+Y D^DIQ S YRST(1)=$E(YRST,4,5)_"/"_$E(YRST,6,7)_"/"_$E(YRST,2,3) W ! S DIR("B")=Y,DIR("A")=" Go to DATE: "
.S DIR(0)="DA^"_+YRST_"::ET",DIR("?")="^D HELP^%DTC"
.I DATSEL["^N+^" S DIR(0)="DA^"_+YRST_":"_DT_":ET",DIR("?")="^S %DT(0)=-DT D HELP^%DTC"
.D ^DIR K %DT(0),DIR I $D(DTOUT)!$D(DUOUT)!(U[X) S POUT=1 Q
.S X1=YRST,X2=+90 D C^%DTC S YRCHK=X
.S YREND=+Y_$S(+Y#1:"",1:".24"),YREND(1)=$E(YREND,4,5)_"/"_$E(YREND,6,7)_"/"_$E(YREND,2,3)
K DATSEL,YR Q
EN2 ; INPUT XFORM: FREQUENCY FIELD IN 452.1
S X=$S(X="1M":.08,X="3M":.25,X="6M":.5,X="1Y":1,X="2Y":2,X="3Y":3,X="1T":0,1:"")
Q
EN3 ; OUTPUT XFORM: FREQUENCY FIELD IN 452.1
S Y=$S(Y=.08:"1M",Y=.25:"3M",Y=.5:"6M",Y=1:"1Y",Y=2:"2Y",Y=3:"3Y",Y=0:"1T",1:"")
Q
DEV ;
S %ZIS="QM" D ^%ZIS K %ZIS K:POP IO("Q") I POP S (POUT,NQT)=1 G Q7
I IO'=IO(0),$E(IOST)="P",'$D(IO("Q")),'$D(IO("S")) W !,$C(7),"THIS REPORT MUST BE QUEUED TO A PRINTER",! G DEV
I $D(PRSE132),IOM<132 D ^%ZISC W !,$C(7)," ** THIS REPORT MUST BE SENT TO A 132 COLUMN DEVICE **",! K IO("Q"),IO("C") G DEV
F X="A*","B*","C*","D*","E*","F*","G*","H*","I*","J*","K*","L*","M*","N*","O*","P*","Q*","R*","S*","T*","U*","V*","W*","X*","Y*","Z*","%H" S ZTSAVE(X)=""
S NQ=0 I $D(IO("Q")) K IO("Q"),IO("C") S NQ=1,ZTIO=ION_";"_IOST_";"_IOM_";"_IOSL D ^%ZTLOAD S NQ=0 S:'$D(ZTSK) POP=1
Q7 K ZTRTN,ZTSAVE
Q
EN3A ; CLASS DATE
W ! S X=U,NSP(1)=0,%DT("A")="Start With CLASS DATE (Press return for all dates): ",%DT="AE",X=U D ^%DT K %DT
I X="" S NSP(1)=1 Q
I Y'>0!(X=U) S POUT=1 Q
S NSPC(1)=Y
W ! S X=U,NSPC(2)=0,%DT("A")="Go To CLASS DATE (Press return for all dates until present date): ",%DT="AE",X=U D ^%DT K %DT
I X="" S X="T" D ^%DT S NSPC(2)=Y Q
I Y'>0!(X=U) S POUT=1 Q
S NSPC(2)=Y
Q
LAYGO(SER) ; LAYGO NODE IN 452.8 DETERMINE IF
; ENTRY CAN BE ADDED. RETURNS 1 IF IT CAN ADD
S:'(+Y>0) SER=2 N DUP S DUP=0 S:'$D(SER)#2 SER=""
I SER="" W !,"CANNOT ADD THIS ENTRY, USE OPTIONS PROVIDED BY PACKAGE."
E I $D(^PRSE(452.8,"AA",SER,X)) W !,"CANNOT ADD THIS ENTRY AS IT WOULD CREATE A DUPLICATE."
E S DUP=1
Q DUP
DICS(FOUND) ; SCREEN 452.1
N VA200DA,VA450DA,SSN,PRSX
S PRSX=0,PRSX(0)=$G(^PRSE(452.1,+Y,0)),SSN=$P($G(^VA(200,DUZ,1)),U,9),VA200DA=DUZ,VA450DA=$O(^PRSPC("SSN",SSN,0))
I $G(REGSW)=1,$$EN2^PRSEUTL2($G(Y)) D
.I $S(DUZ(0)["@":0,+$$EN4^PRSEUTL3($G(DUZ)):0,1:1) I $P($G(PRSX(0)),U,7)="M",$G(PRSESLF),'$D(^PRSPC(+VA450DA,6,"B",+Y)) Q
.I $S(PRSETYP="A":1,1:$P(PRSX(0),U,7)=PRSETYP),($P(PRSX(0),U,8)=PRSESER!($P(PRSX(0),U,9)=0!(DUZ(0)["@"!(+$$EN4^PRSEUTL3($G(DUZ)))))) S (PRSX,FOUND)=1
.Q
I 'FOUND,$$LASTDA(+Y) D MSG20^PRSEMSG W ! K PRSEW
Q PRSX
LASTDA(DA) ; DETERMINE IF DATA IS LAST ENTRY IN 452.1
N X,Y,LAST S LAST=0
S X=$P($G(^PRSE(452.1,DA,0)),U),Y=$O(^PRSE(452.1,"B",X))
I Y="" S Y=$O(^PRSE(452.1,"B",X,DA)) I Y="" S LAST=1
Q LAST
DICS1(FOUND) ; SCREEN 4 LOOKUP IN 452.1
N PRSX S PRSX=0
I '$G(REGSW)=1,$$EN3^PRSEUTL2($G(Y)),$P(^PRSE(452.1,+Y,0),U,7)=PRSETYP,($P(^(0),U,8)=PRSESER!($P(^(0),U,9)=0!(DUZ(0)["@"!(+$$EN4^PRSEUTL3($G(DUZ)))))) S (PRSX,FOUND)=1
I 'FOUND,$$LASTDA(+Y) D MSG20^PRSEMSG W ! K PRSEW
Q PRSX
CLOSE ; CLOSE DEVICE
I '$G(POUT) D ENDPG^PRSEUTL
D ^%ZISC
I $D(ZTQUEUED) S ZTREQ="@"
Q
ENDPG ; HANDLE EOP
I $E(IOST)'="C" Q
K DIR S DIR(0)="E" D ^DIR K DIR S POUT=$S(+Y'>0:1,1:0)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSEUTL 5344 printed Apr 09, 2024@21:27:55 Page 2
PRSEUTL ;HISC/JH/MD-EMPLOYEE EDUCATION REPORT - UTILITY ;4/24/1998
+1 ;;4.0;PAID;**13,25,32,41**;Sep 21, 1995
INS ; INSERVICE SELECTION
+1 SET DIR(0)="SO^M:Mandatory Training (MI);C:Continuing Education;O:Other/Miscellaneous;W:Ward/Unit-Location Training;A:All"
SET DIR("A")="Select Sort Parameter"
+2 DO ^DIR
KILL DIR
IF $DATA(DUOUT)!$DATA(DTOUT)!(U[X)
SET POUT=1
QUIT
+3 SET PRSESEL=Y
+4 QUIT
INS2 ; INSERVICE SELECTION
+1 SET DIR(0)="SO^M:Mandatory Training (MI);C:Continuing Education;O:Other/Miscellaneous;W:Ward/Unit-Location Training;A:All;L:All without Mandatory;H:All without Hosptial Wide Mandatory"
+2 SET DIR("A")="Select Sort Parameter"
+3 DO ^DIR
KILL DIR
IF $DATA(DUOUT)!$DATA(DTOUT)!(U[X)
SET POUT=1
QUIT
+4 SET PRSESEL=Y
+5 QUIT
DATSEL ;
+1 SET DATSEL=U_$GET(DATSEL)_U
SET DIR(0)="SO^C:Calendar Year;F:Fiscal Year;"
+2 IF DATSEL'["^NS^"
SET DIR(0)=DIR(0)_"S:Selected Date Range;"
+3 SET DIR("A")="Select a Sort Parameter"
+4 DO ^DIR
KILL DIR
IF $DATA(DUOUT)!$DATA(DTOUT)!(U[X)
SET POUT=1
QUIT
+5 SET TYP=Y
SET YR=$EXTRACT(DT,1,3)+1700
IF TYP="F"
SET MN=$EXTRACT(DT,4,5)
if MN>9
SET YR=(YR+1)
+6 SET DIR(0)="DA^^K:X'?4N X"
+7 SET X=YR
DO ^%DT
if +Y
DO D^DIQ
SET DIR("B")=Y
SET DIR("?")="This response must be a year i.e. 1990"
+8 IF TYP["C"
SET DIR("A")="Select Calendar Year: "
WRITE !
Begin DoDot:1
+9 DO ^DIR
KILL DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
SET POUT=1
QUIT
+10 SET PYR=$GET(Y(0))
SET YR(6)=$EXTRACT($GET(Y),1,3)+1700
SET %DT=""
SET X=Y
DO ^%DT
SET YRST=+Y
SET %DT=""
SET X="12/31/"_YR(6)
DO ^%DT
SET YREND=+Y_".24"
KILL %DT
SET X1=YRST
SET X2=-90
DO C^%DTC
SET YRCHK=X
End DoDot:1
+11 IF TYP["F"
SET DIR("A")="Select Fiscal Year: "
WRITE !
Begin DoDot:1
+12 DO ^DIR
SET PYR=$GET(Y(0))
SET YR(6)=$EXTRACT(Y,1,3)+1700
KILL DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
SET POUT=1
QUIT
+13 SET %DT=""
SET X="10/"_(YR(6)-1)
DO ^%DT
SET YRST=+Y
SET %DT=""
SET X="9/30/"_YR(6)
DO ^%DT
SET YREND=+Y_".24"
KILL %DT
SET X1=YRST
SET X2=-90
DO C^%DTC
SET YRCHK=X
End DoDot:1
+14 IF TYP["S"
KILL DIR
Begin DoDot:1
+15 WRITE !
SET X=DT
DO ^%DT
if +Y
DO D^DIQ
SET DIR("B")=Y
SET DIR(0)="DA^"_$SELECT($DATA(PRSECAL):DT,1:"")_"::ET"
SET DIR("A")="Start With DATE: "
SET DIR("?")="^S %DT(0)=$S($D(PRSECAL):DT,1:-DT) D HELP^%DTC"
+16 IF DATSEL["^N+^"
SET DIR(0)="DA^:"_DT_":ET"
SET DIR("?")="^S %DT(0)=-DT D HELP^%DTC"
+17 DO ^DIR
KILL %DT(0),DIR
IF $DATA(DTOUT)!$DATA(DUOUT)!(U[X)
SET POUT=1
QUIT
+18 SET YRST=+Y
SET X=DT
SET %DT="T"
DO ^%DT
if +Y
DO D^DIQ
SET YRST(1)=$EXTRACT(YRST,4,5)_"/"_$EXTRACT(YRST,6,7)_"/"_$EXTRACT(YRST,2,3)
WRITE !
SET DIR("B")=Y
SET DIR("A")=" Go to DATE: "
+19 SET DIR(0)="DA^"_+YRST_"::ET"
SET DIR("?")="^D HELP^%DTC"
+20 IF DATSEL["^N+^"
SET DIR(0)="DA^"_+YRST_":"_DT_":ET"
SET DIR("?")="^S %DT(0)=-DT D HELP^%DTC"
+21 DO ^DIR
KILL %DT(0),DIR
IF $DATA(DTOUT)!$DATA(DUOUT)!(U[X)
SET POUT=1
QUIT
+22 SET X1=YRST
SET X2=+90
DO C^%DTC
SET YRCHK=X
+23 SET YREND=+Y_$SELECT(+Y#1:"",1:".24")
SET YREND(1)=$EXTRACT(YREND,4,5)_"/"_$EXTRACT(YREND,6,7)_"/"_$EXTRACT(YREND,2,3)
End DoDot:1
+24 KILL DATSEL,YR
QUIT
EN2 ; INPUT XFORM: FREQUENCY FIELD IN 452.1
+1 SET X=$SELECT(X="1M":.08,X="3M":.25,X="6M":.5,X="1Y":1,X="2Y":2,X="3Y":3,X="1T":0,1:"")
+2 QUIT
EN3 ; OUTPUT XFORM: FREQUENCY FIELD IN 452.1
+1 SET Y=$SELECT(Y=.08:"1M",Y=.25:"3M",Y=.5:"6M",Y=1:"1Y",Y=2:"2Y",Y=3:"3Y",Y=0:"1T",1:"")
+2 QUIT
DEV ;
+1 SET %ZIS="QM"
DO ^%ZIS
KILL %ZIS
if POP
KILL IO("Q")
IF POP
SET (POUT,NQT)=1
GOTO Q7
+2 IF IO'=IO(0)
IF $EXTRACT(IOST)="P"
IF '$DATA(IO("Q"))
IF '$DATA(IO("S"))
WRITE !,$CHAR(7),"THIS REPORT MUST BE QUEUED TO A PRINTER",!
GOTO DEV
+3 IF $DATA(PRSE132)
IF IOM<132
DO ^%ZISC
WRITE !,$CHAR(7)," ** THIS REPORT MUST BE SENT TO A 132 COLUMN DEVICE **",!
KILL IO("Q"),IO("C")
GOTO DEV
+4 FOR X="A*","B*","C*","D*","E*","F*","G*","H*","I*","J*","K*","L*","M*","N*","O*","P*","Q*","R*","S*","T*","U*","V*","W*","X*","Y*","Z*","%H"
SET ZTSAVE(X)=""
+5 SET NQ=0
IF $DATA(IO("Q"))
KILL IO("Q"),IO("C")
SET NQ=1
SET ZTIO=ION_";"_IOST_";"_IOM_";"_IOSL
DO ^%ZTLOAD
SET NQ=0
if '$DATA(ZTSK)
SET POP=1
Q7 KILL ZTRTN,ZTSAVE
+1 QUIT
EN3A ; CLASS DATE
+1 WRITE !
SET X=U
SET NSP(1)=0
SET %DT("A")="Start With CLASS DATE (Press return for all dates): "
SET %DT="AE"
SET X=U
DO ^%DT
KILL %DT
+2 IF X=""
SET NSP(1)=1
QUIT
+3 IF Y'>0!(X=U)
SET POUT=1
QUIT
+4 SET NSPC(1)=Y
+5 WRITE !
SET X=U
SET NSPC(2)=0
SET %DT("A")="Go To CLASS DATE (Press return for all dates until present date): "
SET %DT="AE"
SET X=U
DO ^%DT
KILL %DT
+6 IF X=""
SET X="T"
DO ^%DT
SET NSPC(2)=Y
QUIT
+7 IF Y'>0!(X=U)
SET POUT=1
QUIT
+8 SET NSPC(2)=Y
+9 QUIT
LAYGO(SER) ; LAYGO NODE IN 452.8 DETERMINE IF
+1 ; ENTRY CAN BE ADDED. RETURNS 1 IF IT CAN ADD
+2 if '(+Y>0)
SET SER=2
NEW DUP
SET DUP=0
if '$DATA(SER)#2
SET SER=""
+3 IF SER=""
WRITE !,"CANNOT ADD THIS ENTRY, USE OPTIONS PROVIDED BY PACKAGE."
+4 IF '$TEST
IF $DATA(^PRSE(452.8,"AA",SER,X))
WRITE !,"CANNOT ADD THIS ENTRY AS IT WOULD CREATE A DUPLICATE."
+5 IF '$TEST
SET DUP=1
+6 QUIT DUP
DICS(FOUND) ; SCREEN 452.1
+1 NEW VA200DA,VA450DA,SSN,PRSX
+2 SET PRSX=0
SET PRSX(0)=$GET(^PRSE(452.1,+Y,0))
SET SSN=$PIECE($GET(^VA(200,DUZ,1)),U,9)
SET VA200DA=DUZ
SET VA450DA=$ORDER(^PRSPC("SSN",SSN,0))
+3 IF $GET(REGSW)=1
IF $$EN2^PRSEUTL2($GET(Y))
Begin DoDot:1
+4 IF $SELECT(DUZ(0)["@":0,+$$EN4^PRSEUTL3($GET(DUZ)):0,1:1)
IF $PIECE($GET(PRSX(0)),U,7)="M"
IF $GET(PRSESLF)
IF '$DATA(^PRSPC(+VA450DA,6,"B",+Y))
QUIT
+5 IF $SELECT(PRSETYP="A":1,1:$PIECE(PRSX(0),U,7)=PRSETYP)
IF ($PIECE(PRSX(0),U,8)=PRSESER!($PIECE(PRSX(0),U,9)=0!(DUZ(0)["@"!(+$$EN4^PRSEUTL3($GET(DUZ))))))
SET (PRSX,FOUND)=1
+6 QUIT
End DoDot:1
+7 IF 'FOUND
IF $$LASTDA(+Y)
DO MSG20^PRSEMSG
WRITE !
KILL PRSEW
+8 QUIT PRSX
LASTDA(DA) ; DETERMINE IF DATA IS LAST ENTRY IN 452.1
+1 NEW X,Y,LAST
SET LAST=0
+2 SET X=$PIECE($GET(^PRSE(452.1,DA,0)),U)
SET Y=$ORDER(^PRSE(452.1,"B",X))
+3 IF Y=""
SET Y=$ORDER(^PRSE(452.1,"B",X,DA))
IF Y=""
SET LAST=1
+4 QUIT LAST
DICS1(FOUND) ; SCREEN 4 LOOKUP IN 452.1
+1 NEW PRSX
SET PRSX=0
+2 IF '$GET(REGSW)=1
IF $$EN3^PRSEUTL2($GET(Y))
IF $PIECE(^PRSE(452.1,+Y,0),U,7)=PRSETYP
IF ($PIECE(^(0),U,8)=PRSESER!($PIECE(^(0),U,9)=0!(DUZ(0)["@"!(+$$EN4^PRSEUTL3($GET(DUZ))))))
SET (PRSX,FOUND)=1
+3 IF 'FOUND
IF $$LASTDA(+Y)
DO MSG20^PRSEMSG
WRITE !
KILL PRSEW
+4 QUIT PRSX
CLOSE ; CLOSE DEVICE
+1 IF '$GET(POUT)
DO ENDPG^PRSEUTL
+2 DO ^%ZISC
+3 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+4 QUIT
ENDPG ; HANDLE EOP
+1 IF $EXTRACT(IOST)'="C"
QUIT
+2 KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
SET POUT=$SELECT(+Y'>0:1,1:0)
+3 QUIT
