PRSEPMD5 ;HISC/GLB/JH-INCOMPLETE EMP. M I REPORT ;9/21/1998
;;4.0;PAID;**20,35,44**;Sep 21, 1995
;
;INCOMPLETE EMPLOYEE M I REPORT (BY CLASS) PART 1 OF 2
;
EN1 ; SERVICE EMPLOYEE DEFICIENCY REPORT
S X=$G(^PRSE(452.7,1,"OFF")) I X=""!(X=1) D MSG6^PRSEMSG Q
S (PRSEOUT,NOUT,NQ,NSW1)=0 D EN2^PRSEUTL3(DUZ) I '(PRSESER>0)&'(DUZ(0)="@") D MSG3^PRSEMSG G QUIT
K POUT S DATSEL="NS^N+" D DATSEL^PRSEUTL G:$D(POUT) Q
I '+$$EN4^PRSEUTL3($G(DUZ)),'(DUZ(0)["@") S PSPC=PRSESER("TX"),PSPC(1)=PRSESER G AR
K DIC D EN3^PRSEUTL1 G:$D(POUT) QUIT
AR S CORGCODE=+$O(^PRSP(454,1,"ORG","C",+$G(PSPC(1)),0))
S CORGCODE=$TR($P($G(^PRSP(454,1,"ORG",CORGCODE,0)),U),":")
S DIC("S")="S DATA=$G(^PRSE(452.1,+Y,0)) I $P($G(DATA),U,7)=""M"",($P($G(DATA),U,9)=0!($P($G(DATA),U,8)=PRSESER!(DUZ(0)[""@""!(+$$EN3^PRSEUTL3($G(DUZ))))))" D EN7^PRSEUTL1 G:$D(POUT) Q
W ! S ZTRTN="START^PRSEPMD5",ZTDESC="EMPLOYEE M.I. DEFICIENCY by PROGRAM/CLASS" D LOOP,DEV^PRSEUTL G Q:POP!($D(ZTSK))
;
START ;DEFINE OUTPUT DATE/HEADERS
S PRSE132=$S(IOM'<132:1,1:0)
K ^TMP("PRSE",$J) U IO S (HOLD,HOLD1,HOLD2,COUNT)=0,PRSESERV("OLD")=""
I $G(PSPC(1)) D
. S PRS454=0
. F S PRS454=$O(^PRSP(454,1,"ORG","C",PSPC(1),PRS454)) Q:PRS454'>0 D
.. S CORGCODE=$TR($P($G(^PRSP(454,1,"ORG",PRS454,0)),U),":")
.. I CORGCODE]"" D MAINLOOP
.. Q
. Q
E D
. F S CORGCODE=$O(^PRSPC("ACC",CORGCODE)) Q:CORGCODE="" D MAINLOOP
. Q
D ^PRSEPMD6
;
QUIT ;KILL LOCAL VARIABLES
Q K ^TMP("PRSE",$J)
S POUT=+$G(PRSEOUT)
S:$D(ZTSK) ZTREQ="@" D CLOSE^PRSEUTL
D ^PRSEKILL K DUEDT
Q
;
MAINLOOP ;
S DA=0,PRSESERV=$$SERV(CORGCODE),ONESERV=0
F S DA=$O(^PRSPC("ACC",CORGCODE,DA)) Q:DA'>0 D
.S X(0)=$G(^PRSPC(DA,0)),X(1)=$G(^(1)),SSN=$P(X(0),U,9)
.Q:(SSN="")!($P(X(1),U,33)="Y")
.S PRDA=+$O(^VA(200,"SSN",SSN,0)) Q:PRDA'>0 ;PRDA=IEN of file 200
.S PRSENAME=$P(X(0),U) ; name from 450
.S NSCT="",PRCOD=$S($P(X(0),U,17)'="":$P(X(0),U,17),1:0)
.S NSCT=$$EN12^PRSEUTL2(PRCOD) S:NSCT="" NSCT=" BLANK"
.Q:'+$$EN3^PRSEUTL3($G(PRDA))=PRSESER&'(DUZ(0)="@")&'(+$$EN4^PRSEUTL3($G(DUZ)))
.W:$E(IOST)="C" "."
.S NAM=$S($P(^VA(200,PRDA,0),U)'="":$P(^(0),U),1:" BLANK") ;NAM=200name
.F D1=0:0 S D1=$O(^PRSPC(DA,6,D1)) Q:D1'>0 D
..K DROPDEAD
..S PRSE=$G(^PRSPC(DA,6,D1,0)),CLASSIEN=+$P(PRSE,U) Q:CLASSIEN'>0
..Q:$S($P(PRSE,U,3)'>0:1,$P(PRSE,U,3)>YREND:1,$P(PRSE,U,3)>DT:1,1:0)
..S CLASS=$G(^PRSE(452.1,CLASSIEN,0)) Q:CLASS=""
..I $P(CLASS,U,7)'="M" Q ; Only Mandatory Inservice
..S CLASSTXT=$P(CLASS,U),FREQ=+$P(CLASS,U,6)
..I 'NSP,PRSECLS=CLASSTXT S ONESERV=1
..S CLASSTXT(0)=$S(PRSE132:CLASSTXT,1:$E(CLASSTXT,1,25))
..S:CLASSTXT(0)="" CLASSTXT(0)=" BLANK"
..I 'NSP,PRSECLS'=CLASSTXT Q
..I $D(PSPC(1)),'(+PSPC(1)=+$$EN3^PRSEUTL3($G(PRDA))) Q
..I PRSESERV]"",$G(^TMP("PRSE",$J,"DA",DA))'>0 D
...S TMP=$G(^TMP("PRSE",$J,"%",PRSESERV)) S:TMP="01" TMP=0 S $P(TMP,U)=$P(TMP,U)+1
...S ^TMP("PRSE",$J,"%",PRSESERV)=TMP,^TMP("PRSE",$J,"DA",DA)=1
...Q
..;I "^C^F^"[(U_TYP_U),FREQ<1 Q
..;I "S"=TYP,FREQ'<1 Q
..S DATE=+$O(^PRSE(452,"AA","M",PRDA,CLASSTXT,0))
..S LASTDATE=$S(DATE:9999999-DATE\1,1:0) ;date last took course
..I 'LASTDATE S LASTDATE=$P(PRSE,U,3)
..I $E(LASTDATE,6,7)="00" D
...N MONTH,YEAR
...S MONTH=+$E(LASTDATE,4,5),YEAR=1700+$E(LASTDATE,1,3)
...S LASTDAY=$P("31^"_(28+$$LEAPYR^PRSLIB00(YEAR))_"^31^30^31^30^31^31^30^31^30^31",U,MONTH)
...S LASTDATE=$E(LASTDATE,1,5)_LASTDAY
...Q
..S X1=LASTDATE,X2=$J(FREQ*365.25,0,0) D C^%DTC S DROPDEAD=X
..I FREQ=0,DATE Q ; ONE TIME ONLY CLASS
..I DROPDEAD>YREND Q
..Q:$S(DROPDEAD'<YRST:0,DROPDEAD'>YREND:0,1:1)
..I $G(CLASSNUM)'>0 S CLASSNUM=1
..S CLASSNUM(0)=+$G(^TMP("PRSE",$J,"SORT1",PRSESERV,NSCT))
..I CLASSNUM(0)'>0 D
...S CLASSNUM(0)=CLASSNUM,CLASSNUM=CLASSNUM+1
...S ^TMP("PRSE",$J,"SORT1",PRSESERV,NSCT)=CLASSNUM(0)
...Q
..S ^TMP("PRSE",$J,"SORT2",CLASSNUM(0),PRSENAME,CLASSTXT(0))=$G(DROPDEAD)
..I PRSESERV]"",$G(^TMP("PRSE",$J,"DA",DA))'>1 D
...S TMP=$G(^TMP("PRSE",$J,"%",PRSESERV)) I $G(DROPDEAD)'>$G(DT) S $P(TMP,U,2)=$P(TMP,U,2)+1
...;to calculate compliance use TODAY as the date to compute attendance
...;see SUBHDR^PRSEPMD6
...S ^TMP("PRSE",$J,"%",PRSESERV)=TMP,^TMP("PRSE",$J,"DA",DA)=2
...Q
..Q
.Q
I ($G(NSP)!($G(NSP)'>0&ONESERV)),'$D(^TMP("PRSE",$J,"SORT1",PRSESERV)) D
.S ^TMP("PRSE",$J,"SORT1",PRSESERV)="",^TMP("PRSE",$J,"%",PRSESERV)="01"
.Q
Q
;
LOOP F X="PSP","PSPC","PSPC(","CORGCODE","PYR","NSP","PRDA","PRSESE","YRCHK","YRST","YREND","REQWRD","NCAT","NSCAT","NHOS","NWRD","NSW1","NOUT","PRSEOUT","TYP","PRSECLS","PRSECLS(","PRSEDA","PRSECHK","PRSENAM","PRSESER" D
. S ZTSAVE(X)=""
Q
;
SERV(COSTCEN) ;
N NLOC
S COSTCEN=$E(COSTCEN,1,4)_":"_$E(COSTCEN,5,8)
S COSTCEN=+$O(^PRSP(454,1,"ORG","B",COSTCEN,0))
S NLOC=+$P($G(^PRSP(454,1,"ORG",COSTCEN,0)),U,2)
S NLOC=$P($G(^PRSP(454.1,NLOC,0)),U)
S:NLOC="" NLOC=" BLANK"
Q NLOC
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSEPMD5 4923 printed Nov 22, 2024@17:36:48 Page 2
PRSEPMD5 ;HISC/GLB/JH-INCOMPLETE EMP. M I REPORT ;9/21/1998
+1 ;;4.0;PAID;**20,35,44**;Sep 21, 1995
+2 ;
+3 ;INCOMPLETE EMPLOYEE M I REPORT (BY CLASS) PART 1 OF 2
+4 ;
EN1 ; SERVICE EMPLOYEE DEFICIENCY REPORT
+1 SET X=$GET(^PRSE(452.7,1,"OFF"))
IF X=""!(X=1)
DO MSG6^PRSEMSG
QUIT
+2 SET (PRSEOUT,NOUT,NQ,NSW1)=0
DO EN2^PRSEUTL3(DUZ)
IF '(PRSESER>0)&'(DUZ(0)="@")
DO MSG3^PRSEMSG
GOTO QUIT
+3 KILL POUT
SET DATSEL="NS^N+"
DO DATSEL^PRSEUTL
if $DATA(POUT)
GOTO Q
+4 IF '+$$EN4^PRSEUTL3($GET(DUZ))
IF '(DUZ(0)["@")
SET PSPC=PRSESER("TX")
SET PSPC(1)=PRSESER
GOTO AR
+5 KILL DIC
DO EN3^PRSEUTL1
if $DATA(POUT)
GOTO QUIT
AR SET CORGCODE=+$ORDER(^PRSP(454,1,"ORG","C",+$GET(PSPC(1)),0))
+1 SET CORGCODE=$TRANSLATE($PIECE($GET(^PRSP(454,1,"ORG",CORGCODE,0)),U),":")
+2 SET DIC("S")="S DATA=$G(^PRSE(452.1,+Y,0)) I $P($G(DATA),U,7)=""M"",($P($G(DATA),U,9)=0!($P($G(DATA),U,8)=PRSESER!(DUZ(0)[""@""!(+$$EN3^PRSEUTL3($G(DUZ))))))"
DO EN7^PRSEUTL1
if $DATA(POUT)
GOTO Q
+3 WRITE !
SET ZTRTN="START^PRSEPMD5"
SET ZTDESC="EMPLOYEE M.I. DEFICIENCY by PROGRAM/CLASS"
DO LOOP
DO DEV^PRSEUTL
if POP!($DATA(ZTSK))
GOTO Q
+4 ;
START ;DEFINE OUTPUT DATE/HEADERS
+1 SET PRSE132=$SELECT(IOM'<132:1,1:0)
+2 KILL ^TMP("PRSE",$JOB)
USE IO
SET (HOLD,HOLD1,HOLD2,COUNT)=0
SET PRSESERV("OLD")=""
+3 IF $GET(PSPC(1))
Begin DoDot:1
+4 SET PRS454=0
+5 FOR
SET PRS454=$ORDER(^PRSP(454,1,"ORG","C",PSPC(1),PRS454))
if PRS454'>0
QUIT
Begin DoDot:2
+6 SET CORGCODE=$TRANSLATE($PIECE($GET(^PRSP(454,1,"ORG",PRS454,0)),U),":")
+7 IF CORGCODE]""
DO MAINLOOP
+8 QUIT
End DoDot:2
+9 QUIT
End DoDot:1
+10 IF '$TEST
Begin DoDot:1
+11 FOR
SET CORGCODE=$ORDER(^PRSPC("ACC",CORGCODE))
if CORGCODE=""
QUIT
DO MAINLOOP
+12 QUIT
End DoDot:1
+13 DO ^PRSEPMD6
+14 ;
QUIT ;KILL LOCAL VARIABLES
Q KILL ^TMP("PRSE",$JOB)
+1 SET POUT=+$GET(PRSEOUT)
+2 if $DATA(ZTSK)
SET ZTREQ="@"
DO CLOSE^PRSEUTL
+3 DO ^PRSEKILL
KILL DUEDT
+4 QUIT
+5 ;
MAINLOOP ;
+1 SET DA=0
SET PRSESERV=$$SERV(CORGCODE)
SET ONESERV=0
+2 FOR
SET DA=$ORDER(^PRSPC("ACC",CORGCODE,DA))
if DA'>0
QUIT
Begin DoDot:1
+3 SET X(0)=$GET(^PRSPC(DA,0))
SET X(1)=$GET(^(1))
SET SSN=$PIECE(X(0),U,9)
+4 if (SSN="")!($PIECE(X(1),U,33)="Y")
QUIT
+5 ;PRDA=IEN of file 200
SET PRDA=+$ORDER(^VA(200,"SSN",SSN,0))
if PRDA'>0
QUIT
+6 ; name from 450
SET PRSENAME=$PIECE(X(0),U)
+7 SET NSCT=""
SET PRCOD=$SELECT($PIECE(X(0),U,17)'="":$PIECE(X(0),U,17),1:0)
+8 SET NSCT=$$EN12^PRSEUTL2(PRCOD)
if NSCT=""
SET NSCT=" BLANK"
+9 if '+$$EN3^PRSEUTL3($GET(PRDA))=PRSESER&'(DUZ(0)="@")&'(+$$EN4^PRSEUTL3($GET(DUZ)))
QUIT
+10 if $EXTRACT(IOST)="C"
WRITE "."
+11 ;NAM=200name
SET NAM=$SELECT($PIECE(^VA(200,PRDA,0),U)'="":$PIECE(^(0),U),1:" BLANK")
+12 FOR D1=0:0
SET D1=$ORDER(^PRSPC(DA,6,D1))
if D1'>0
QUIT
Begin DoDot:2
+13 KILL DROPDEAD
+14 SET PRSE=$GET(^PRSPC(DA,6,D1,0))
SET CLASSIEN=+$PIECE(PRSE,U)
if CLASSIEN'>0
QUIT
+15 if $SELECT($PIECE(PRSE,U,3)'>0
QUIT
+16 SET CLASS=$GET(^PRSE(452.1,CLASSIEN,0))
if CLASS=""
QUIT
+17 ; Only Mandatory Inservice
IF $PIECE(CLASS,U,7)'="M"
QUIT
+18 SET CLASSTXT=$PIECE(CLASS,U)
SET FREQ=+$PIECE(CLASS,U,6)
+19 IF 'NSP
IF PRSECLS=CLASSTXT
SET ONESERV=1
+20 SET CLASSTXT(0)=$SELECT(PRSE132:CLASSTXT,1:$EXTRACT(CLASSTXT,1,25))
+21 if CLASSTXT(0)=""
SET CLASSTXT(0)=" BLANK"
+22 IF 'NSP
IF PRSECLS'=CLASSTXT
QUIT
+23 IF $DATA(PSPC(1))
IF '(+PSPC(1)=+$$EN3^PRSEUTL3($GET(PRDA)))
QUIT
+24 IF PRSESERV]""
IF $GET(^TMP("PRSE",$JOB,"DA",DA))'>0
Begin DoDot:3
+25 SET TMP=$GET(^TMP("PRSE",$JOB,"%",PRSESERV))
if TMP="01"
SET TMP=0
SET $PIECE(TMP,U)=$PIECE(TMP,U)+1
+26 SET ^TMP("PRSE",$JOB,"%",PRSESERV)=TMP
SET ^TMP("PRSE",$JOB,"DA",DA)=1
+27 QUIT
End DoDot:3
+28 ;I "^C^F^"[(U_TYP_U),FREQ<1 Q
+29 ;I "S"=TYP,FREQ'<1 Q
+30 SET DATE=+$ORDER(^PRSE(452,"AA","M",PRDA,CLASSTXT,0))
+31 ;date last took course
SET LASTDATE=$SELECT(DATE:9999999-DATE\1,1:0)
+32 IF 'LASTDATE
SET LASTDATE=$PIECE(PRSE,U,3)
+33 IF $EXTRACT(LASTDATE,6,7)="00"
Begin DoDot:3
+34 NEW MONTH,YEAR
+35 SET MONTH=+$EXTRACT(LASTDATE,4,5)
SET YEAR=1700+$EXTRACT(LASTDATE,1,3)
+36 SET LASTDAY=$PIECE("31^"_(28+$$LEAPYR^PRSLIB00(YEAR))_"^31^30^31^30^31^31^30^31^30^31",U,MONTH)
+37 SET LASTDATE=$EXTRACT(LASTDATE,1,5)_LASTDAY
+38 QUIT
End DoDot:3
+39 SET X1=LASTDATE
SET X2=$JUSTIFY(FREQ*365.25,0,0)
DO C^%DTC
SET DROPDEAD=X
+40 ; ONE TIME ONLY CLASS
IF FREQ=0
IF DATE
QUIT
+41 IF DROPDEAD>YREND
QUIT
+42 if $SELECT(DROPDEAD'<YRST
QUIT
+43 IF $GET(CLASSNUM)'>0
SET CLASSNUM=1
+44 SET CLASSNUM(0)=+$GET(^TMP("PRSE",$JOB,"SORT1",PRSESERV,NSCT))
+45 IF CLASSNUM(0)'>0
Begin DoDot:3
+46 SET CLASSNUM(0)=CLASSNUM
SET CLASSNUM=CLASSNUM+1
+47 SET ^TMP("PRSE",$JOB,"SORT1",PRSESERV,NSCT)=CLASSNUM(0)
+48 QUIT
End DoDot:3
+49 SET ^TMP("PRSE",$JOB,"SORT2",CLASSNUM(0),PRSENAME,CLASSTXT(0))=$GET(DROPDEAD)
+50 IF PRSESERV]""
IF $GET(^TMP("PRSE",$JOB,"DA",DA))'>1
Begin DoDot:3
+51 SET TMP=$GET(^TMP("PRSE",$JOB,"%",PRSESERV))
IF $GET(DROPDEAD)'>$GET(DT)
SET $PIECE(TMP,U,2)=$PIECE(TMP,U,2)+1
+52 ;to calculate compliance use TODAY as the date to compute attendance
+53 ;see SUBHDR^PRSEPMD6
+54 SET ^TMP("PRSE",$JOB,"%",PRSESERV)=TMP
SET ^TMP("PRSE",$JOB,"DA",DA)=2
+55 QUIT
End DoDot:3
+56 QUIT
End DoDot:2
+57 QUIT
End DoDot:1
+58 IF ($GET(NSP)!($GET(NSP)'>0&ONESERV))
IF '$DATA(^TMP("PRSE",$JOB,"SORT1",PRSESERV))
Begin DoDot:1
+59 SET ^TMP("PRSE",$JOB,"SORT1",PRSESERV)=""
SET ^TMP("PRSE",$JOB,"%",PRSESERV)="01"
+60 QUIT
End DoDot:1
+61 QUIT
+62 ;
LOOP FOR X="PSP","PSPC","PSPC(","CORGCODE","PYR","NSP","PRDA","PRSESE","YRCHK","YRST","YREND","REQWRD","NCAT","NSCAT","NHOS","NWRD","NSW1","NOUT","PRSEOUT","TYP","PRSECLS","PRSECLS(","PRSEDA","PRSECHK","PRSENAM","PRSESER"
Begin DoDot:1
+1 SET ZTSAVE(X)=""
End DoDot:1
+2 QUIT
+3 ;
SERV(COSTCEN) ;
+1 NEW NLOC
+2 SET COSTCEN=$EXTRACT(COSTCEN,1,4)_":"_$EXTRACT(COSTCEN,5,8)
+3 SET COSTCEN=+$ORDER(^PRSP(454,1,"ORG","B",COSTCEN,0))
+4 SET NLOC=+$PIECE($GET(^PRSP(454,1,"ORG",COSTCEN,0)),U,2)
+5 SET NLOC=$PIECE($GET(^PRSP(454.1,NLOC,0)),U)
+6 if NLOC=""
SET NLOC=" BLANK"
+7 QUIT NLOC
