PRSEPMD4 ;HISC/JH-INDIVIDUAL M I DEFICIENCY BY EMPLOYEE ; 9/21/1998
;;4.0;PAID;**20,35,44**;Sep 21, 1995
EN1 ; DEFICIENCY REPORT FOR SERVICE(S)
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) D MSG3^PRSEMSG G QUIT
K POUT S DATSEL="NS^N+" D DATSEL^PRSEUTL G:$D(POUT) QUIT
NAME K DIC S DIC("S")="I (+$$EN4^PRSEUTL3($G(DUZ))!(DUZ(0)[""@""!(+$$EN6^PRSEUTL3($G(DUZ))&(+$$EN3^PRSEUTL3(+$G(Y))=PRSESER))))"
I (+$$EN4^PRSEUTL3($G(DUZ))!(+$$EN6^PRSEUTL3($G(DUZ))!(DUZ(0)["@"))) D
.W ! S DIC("A")="Select EMPLOYEE NAME: ",DIC("W")="I $P($G(^VA(200,+Y,1)),U,9)?9N W ?$X+5,$P(^(1),U,9)",DIC(0)="AEMQI",DIC="^VA(200," D ^DIC K DIC S DA=+Y Q
E S DA=DUZ
I $D(DUOUT)!($D(DTOUT))!'(+Y>0) S POUT=1 G QUIT
S SSN=$P($G(^VA(200,DA,1)),U,9) S:SSN="" SSN=U
S DA=$O(^PRSPC("SSN",SSN,0))
I DA'>0 D G NAME
. W !!?5,"No SSN found for this person or, no entry for"
. W !?5,"this person is found in the PAID EMPLOYEE file (#450)."
. Q
I $P($G(^PRSPC(+$G(DA),1)),U,33)="Y" D G NAME ;check for separtation IND
. W !!?5,"Employee selected is no longer active. Separation"
. W !?5,"Indicator is set to 'Yes'."
. Q
S NAM=$P($G(^PRSPC(DA,0)),U)
S COSTCEN=$P($G(^PRSPC(DA,0)),U,49),COSTCEN=$E(COSTCEN,1,4)_":"_$E(COSTCEN,5,8),COSTCEN=+$O(^PRSP(454,1,"ORG","B",COSTCEN,0))
S NLOC=+$P($G(^PRSP(454,1,"ORG",COSTCEN,0)),U,2),NLOC=$P($G(^PRSP(454.1,NLOC,0)),U) S:NLOC="" NLOC=" BLANK"
W ! S ZTRTN="START^PRSEPMD4",ZTDESC="INDIVIDUAL M.I. DEFICIENCY by EMPLOYEE NAME" D LOOP,DEV^PRSEUTL G:POP!($D(ZTSK)) QUIT
START ;DEFINE FISCAL YEAR DATE AND HEADERS FOR OUTPUT DATA REPORT
K ^TMP("PRSE",$J) U IO S (HOLD,COUNT)=0,PRSE132=$S(IOM'<132:1,1:0)
I (+DA>0) S PRCOD=$P($G(^PRSPC(DA,0)),U,17),SSN=$P(^PRSPC(DA,0),U,9) I SSN'="" S VA200DA=$O(^VA(200,"SSN",SSN,0)) D
.W:$E(IOST)="C" "."
.S NSCT="",NSCT=$$EN12^PRSEUTL2($G(PRCOD)) S:NSCT="" NSCT=" BLANK"
.S NAM=$S($P(^PRSPC(DA,0),U)'="":$P(^(0),U),1:" BLANK") K DROPDEAD
.F PURDA=0:0 S PURDA=$O(^PRSPC(DA,6,PURDA)) Q:PURDA'>0 D
..S PRSE=$G(^PRSPC(DA,6,PURDA,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)
..S CLASSTXT(0)=$S(PRSE132:CLASSTXT,1:$E(CLASSTXT,1,25))
..S:CLASSTXT(0)="" CLASSTXT(0)=" BLANK"
..;I "^C^F^"[(U_TYP_U),FREQ<1 Q
..;I "S"=TYP,FREQ'<1 Q
..S DATE=$O(^PRSE(452,"AA","M",VA200DA,CLASSTXT,0))
..I FREQ=0,DATE Q ; ONE TIME ONLY CLASS
..S LASTDATE=$S(DATE:9999999-DATE\1,1:0)
..I 'LASTDATE S LASTDATE=$P(PRSE,U,3)
..I $E(LASTDATE,6,7)="00" D
...N MONTH,YEAR,LEAP
...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
.. ;$P(PRSE,U,3)=date assigned MI course. Will use as
.. ;computation date if course never taken (set to LASTDATE above)
..S DROPDEAD=X
..; DROPDEAD=last possible date before deliquency
..I DROPDEAD>YREND Q
.. Q:$S(DROPDEAD'<YRST:0,DROPDEAD'>YREND:0,1:1)
..S ^TMP("PRSE",$J,"L",CLASSTXT(0),NSCT)=NAM_U_DROPDEAD
..Q
.Q
I $O(^TMP("PRSE",$J,"L",""))="" D G QUIT
.D HDR^PRSEPMD1 W !,"No deficiencies found for '",NAM,"' during this period.",!!
.Q
S CLASSTXT="" F S CLASSTXT=$O(^TMP("PRSE",$J,"L",CLASSTXT)) Q:CLASSTXT=""!PRSEOUT S NSCT="" F S NSCT=$O(^TMP("PRSE",$J,"L",CLASSTXT,NSCT)) Q:NSCT=""!PRSEOUT D
.D:($Y>(IOSL-7))!'(NSW1) HDR^PRSEPMD1 Q:PRSEOUT
.S NAM=$P(^TMP("PRSE",$J,"L",CLASSTXT,NSCT),U),DROPDEAD=$P(^(NSCT),U,2)
.W ! W:NAM'=" BLANK"&HOLD=1 $S(PRSE132:NAM,1:$E(NAM,1,23))
.W:NLOC'=" BLANK"&HOLD=1 ?$S(PRSE132:33,1:20),$E(NLOC,1,$S(PRSE132:22,1:14))
.W ?$S(PRSE132:56,1:37),$$FMTE^XLFDT(DROPDEAD,2)
.W:CLASSTXT'=" BLANK" ?$S(PRSE132:79,1:55),CLASSTXT
.S (HOLD,DROPDEAD)=0
.Q
QUIT ;
K ^TMP("PRSE",$J)
D CLOSE^PRSEUTL
D ^PRSEKILL K POUT
Q
LOOP F X="NAM","PYR","PRDA","DA(","PRSESEL","TYP","DA","REQWRD","NCAT","NSCAT","NHOS","NWRD","NSW1","NOUT","PRSEOUT","PRSESER","PRSENAM","YREND","YRST","NLOC" S ZTSAVE(X)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSEPMD4 4300 printed Oct 16, 2024@18:27:29 Page 2
PRSEPMD4 ;HISC/JH-INDIVIDUAL M I DEFICIENCY BY EMPLOYEE ; 9/21/1998
+1 ;;4.0;PAID;**20,35,44**;Sep 21, 1995
EN1 ; DEFICIENCY REPORT FOR SERVICE(S)
+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)
DO MSG3^PRSEMSG
GOTO QUIT
+3 KILL POUT
SET DATSEL="NS^N+"
DO DATSEL^PRSEUTL
if $DATA(POUT)
GOTO QUIT
NAME KILL DIC
SET DIC("S")="I (+$$EN4^PRSEUTL3($G(DUZ))!(DUZ(0)[""@""!(+$$EN6^PRSEUTL3($G(DUZ))&(+$$EN3^PRSEUTL3(+$G(Y))=PRSESER))))"
+1 IF (+$$EN4^PRSEUTL3($GET(DUZ))!(+$$EN6^PRSEUTL3($GET(DUZ))!(DUZ(0)["@")))
Begin DoDot:1
+2 WRITE !
SET DIC("A")="Select EMPLOYEE NAME: "
SET DIC("W")="I $P($G(^VA(200,+Y,1)),U,9)?9N W ?$X+5,$P(^(1),U,9)"
SET DIC(0)="AEMQI"
SET DIC="^VA(200,"
DO ^DIC
KILL DIC
SET DA=+Y
QUIT
End DoDot:1
+3 IF '$TEST
SET DA=DUZ
+4 IF $DATA(DUOUT)!($DATA(DTOUT))!'(+Y>0)
SET POUT=1
GOTO QUIT
+5 SET SSN=$PIECE($GET(^VA(200,DA,1)),U,9)
if SSN=""
SET SSN=U
+6 SET DA=$ORDER(^PRSPC("SSN",SSN,0))
+7 IF DA'>0
Begin DoDot:1
+8 WRITE !!?5,"No SSN found for this person or, no entry for"
+9 WRITE !?5,"this person is found in the PAID EMPLOYEE file (#450)."
+10 QUIT
End DoDot:1
GOTO NAME
+11 ;check for separtation IND
IF $PIECE($GET(^PRSPC(+$GET(DA),1)),U,33)="Y"
Begin DoDot:1
+12 WRITE !!?5,"Employee selected is no longer active. Separation"
+13 WRITE !?5,"Indicator is set to 'Yes'."
+14 QUIT
End DoDot:1
GOTO NAME
+15 SET NAM=$PIECE($GET(^PRSPC(DA,0)),U)
+16 SET COSTCEN=$PIECE($GET(^PRSPC(DA,0)),U,49)
SET COSTCEN=$EXTRACT(COSTCEN,1,4)_":"_$EXTRACT(COSTCEN,5,8)
SET COSTCEN=+$ORDER(^PRSP(454,1,"ORG","B",COSTCEN,0))
+17 SET NLOC=+$PIECE($GET(^PRSP(454,1,"ORG",COSTCEN,0)),U,2)
SET NLOC=$PIECE($GET(^PRSP(454.1,NLOC,0)),U)
if NLOC=""
SET NLOC=" BLANK"
+18 WRITE !
SET ZTRTN="START^PRSEPMD4"
SET ZTDESC="INDIVIDUAL M.I. DEFICIENCY by EMPLOYEE NAME"
DO LOOP
DO DEV^PRSEUTL
if POP!($DATA(ZTSK))
GOTO QUIT
START ;DEFINE FISCAL YEAR DATE AND HEADERS FOR OUTPUT DATA REPORT
+1 KILL ^TMP("PRSE",$JOB)
USE IO
SET (HOLD,COUNT)=0
SET PRSE132=$SELECT(IOM'<132:1,1:0)
+2 IF (+DA>0)
SET PRCOD=$PIECE($GET(^PRSPC(DA,0)),U,17)
SET SSN=$PIECE(^PRSPC(DA,0),U,9)
IF SSN'=""
SET VA200DA=$ORDER(^VA(200,"SSN",SSN,0))
Begin DoDot:1
+3 if $EXTRACT(IOST)="C"
WRITE "."
+4 SET NSCT=""
SET NSCT=$$EN12^PRSEUTL2($GET(PRCOD))
if NSCT=""
SET NSCT=" BLANK"
+5 SET NAM=$SELECT($PIECE(^PRSPC(DA,0),U)'="":$PIECE(^(0),U),1:" BLANK")
KILL DROPDEAD
+6 FOR PURDA=0:0
SET PURDA=$ORDER(^PRSPC(DA,6,PURDA))
if PURDA'>0
QUIT
Begin DoDot:2
+7 SET PRSE=$GET(^PRSPC(DA,6,PURDA,0))
SET CLASSIEN=+$PIECE(PRSE,U)
if CLASSIEN'>0
QUIT
+8 if $SELECT($PIECE(PRSE,U,3)'>0
QUIT
+9 SET CLASS=$GET(^PRSE(452.1,CLASSIEN,0))
if CLASS=""
QUIT
+10 ; Only Mandatory Inservice
IF $PIECE(CLASS,U,7)'="M"
QUIT
+11 SET CLASSTXT=$PIECE(CLASS,U)
SET FREQ=+$PIECE(CLASS,U,6)
+12 SET CLASSTXT(0)=$SELECT(PRSE132:CLASSTXT,1:$EXTRACT(CLASSTXT,1,25))
+13 if CLASSTXT(0)=""
SET CLASSTXT(0)=" BLANK"
+14 ;I "^C^F^"[(U_TYP_U),FREQ<1 Q
+15 ;I "S"=TYP,FREQ'<1 Q
+16 SET DATE=$ORDER(^PRSE(452,"AA","M",VA200DA,CLASSTXT,0))
+17 ; ONE TIME ONLY CLASS
IF FREQ=0
IF DATE
QUIT
+18 SET LASTDATE=$SELECT(DATE:9999999-DATE\1,1:0)
+19 IF 'LASTDATE
SET LASTDATE=$PIECE(PRSE,U,3)
+20 IF $EXTRACT(LASTDATE,6,7)="00"
Begin DoDot:3
+21 NEW MONTH,YEAR,LEAP
+22 SET MONTH=+$EXTRACT(LASTDATE,4,5)
SET YEAR=1700+$EXTRACT(LASTDATE,1,3)
+23 SET LASTDAY=$PIECE("31^"_(28+$$LEAPYR^PRSLIB00(YEAR))_"^31^30^31^30^31^31^30^31^30^31",U,MONTH)
+24 SET LASTDATE=$EXTRACT(LASTDATE,1,5)_LASTDAY
+25 QUIT
End DoDot:3
+26 SET X1=LASTDATE
SET X2=$JUSTIFY(FREQ*365.25,0,0)
DO C^%DTC
+27 ;$P(PRSE,U,3)=date assigned MI course. Will use as
+28 ;computation date if course never taken (set to LASTDATE above)
+29 SET DROPDEAD=X
+30 ; DROPDEAD=last possible date before deliquency
+31 IF DROPDEAD>YREND
QUIT
+32 if $SELECT(DROPDEAD'<YRST
QUIT
+33 SET ^TMP("PRSE",$JOB,"L",CLASSTXT(0),NSCT)=NAM_U_DROPDEAD
+34 QUIT
End DoDot:2
+35 QUIT
End DoDot:1
+36 IF $ORDER(^TMP("PRSE",$JOB,"L",""))=""
Begin DoDot:1
+37 DO HDR^PRSEPMD1
WRITE !,"No deficiencies found for '",NAM,"' during this period.",!!
+38 QUIT
End DoDot:1
GOTO QUIT
+39 SET CLASSTXT=""
FOR
SET CLASSTXT=$ORDER(^TMP("PRSE",$JOB,"L",CLASSTXT))
if CLASSTXT=""!PRSEOUT
QUIT
SET NSCT=""
FOR
SET NSCT=$ORDER(^TMP("PRSE",$JOB,"L",CLASSTXT,NSCT))
if NSCT=""!PRSEOUT
QUIT
Begin DoDot:1
+40 if ($Y>(IOSL-7))!'(NSW1)
DO HDR^PRSEPMD1
if PRSEOUT
QUIT
+41 SET NAM=$PIECE(^TMP("PRSE",$JOB,"L",CLASSTXT,NSCT),U)
SET DROPDEAD=$PIECE(^(NSCT),U,2)
+42 WRITE !
if NAM'=" BLANK"&HOLD=1
WRITE $SELECT(PRSE132:NAM,1:$EXTRACT(NAM,1,23))
+43 if NLOC'=" BLANK"&HOLD=1
WRITE ?$SELECT(PRSE132:33,1:20),$EXTRACT(NLOC,1,$SELECT(PRSE132:22,1:14))
+44 WRITE ?$SELECT(PRSE132:56,1:37),$$FMTE^XLFDT(DROPDEAD,2)
+45 if CLASSTXT'=" BLANK"
WRITE ?$SELECT(PRSE132:79,1:55),CLASSTXT
+46 SET (HOLD,DROPDEAD)=0
+47 QUIT
End DoDot:1
QUIT ;
+1 KILL ^TMP("PRSE",$JOB)
+2 DO CLOSE^PRSEUTL
+3 DO ^PRSEKILL
KILL POUT
+4 QUIT
LOOP FOR X="NAM","PYR","PRDA","DA(","PRSESEL","TYP","DA","REQWRD","NCAT","NSCAT","NHOS","NWRD","NSW1","NOUT","PRSEOUT","PRSESER","PRSENAM","YREND","YRST","NLOC"
SET ZTSAVE(X)=""
+1 QUIT
