ENTIRC ;WOIFO/LKG - Certify IT Acceptance ;2/5/08 14:48
;;7.0;ENGINEERING;**87,89**;Aug 17, 1993;Build 20
IN ;Entry point
N D,DIC,DTOUT,DUOUT,DIRUT,DIROUT,DIR,ENDA,ENDAC,ENNAME,ENI,ENJ,ENDATE,ENCNT,ENX,ENZ,X,X1,Y,L,DIC,FLDS,FR,TO,BY,IOP,DHD
LOOPST ;
S:'$G(DT) DT=$$DT^XLFDT()
K D,DIC S DIC=200,DIC(0)="AEMQ",DIC("S")="I $D(^ENG(6916.3,""AOA"",Y))"
D ^DIC K DIC I $D(DTOUT)!$D(DUOUT)!(Y<1) G EX
S ENDA=+Y,ENNAME=$P(Y,U,2)
K D,^TMP($J,"ENITRC"),ENERR
D FIND^DIC(6916.3,"","@;.01;1;20","PQX",ENDA,"","AOA2","I $P(^(0),U,8)="""",$S($P(^(0),U,5)="""":1,$$FMDIFF^XLFDT(DT,$P(^(0),U,5))>359:1,1:0)","","^TMP($J,""ENITRC"")","ENERR")
I $P($G(^TMP($J,"ENITRC","DILIST",0)),U)'>0 W !!,"There are no unaccepted IT responsibilities to be certified." K DIR S DIR(0)="E" D ^DIR K DIR K ^TMP($J,"ENITRC") G EX:'Y,LOOPST
K ^TMP($J,"SCR"),^TMP($J,"INDX"),ENACL W !
S ^TMP($J,"SCR")=$P(^TMP($J,"ENITRC","DILIST",0),U)_"^IT RESPONSIBILITIES TO CERTIFY FOR "_ENNAME
S ^TMP($J,"SCR",0)="5;9;ENTRY #^15;20;MFG EQUIP NAME^37;25;MODEL^65;14;SERIAL#"
S ENI=0
F S ENI=$O(^TMP($J,"ENITRC","DILIST",ENI)) Q:+ENI'>0 D
. N ENX,END,ENERR S ENX=$G(^TMP($J,"ENITRC","DILIST",ENI,0))
. S ENDAC=$P(ENX,U,2)_"," D GETS^DIQ(6914,ENDAC,"3;4;5","E","END","ENERR")
. S ^TMP($J,"SCR",ENI)=$P(ENX,U,2)_U_$E($G(END(6914,ENDAC,3,"E")),1,20)_U_$G(END(6914,ENDAC,4,"E"))_U_$G(END(6914,ENDAC,5,"E"))
. S ^TMP($J,"INDX",ENI)=$P(ENX,U)
K ^TMP($J,"ENITRC")
D EN2^ENPLS2(1) G:'$D(ENACL) EX
K DIR S DIR(0)="Y",DIR("A")="OK to continue",DIR("B")="NO" D ^DIR K DIR
G:'Y!$D(DIRUT) EX
S ENDA=$O(^ENG(6916.2,"@"),-1)
I '$$CMP^XUSESIG1($P($G(^ENG(6916.2,ENDA,0)),U,3),$NAME(^ENG(6916.2,ENDA,1))) W !!,"Hand receipt text is corrupted - Please contact EPS AEMS/MERS support" G EX
K L,DIC,FLDS,FR,TO,BY,IOP,DHD
S L=0,DIC=6916.2,FLDS=1,FR=ENDA,TO=ENDA,BY="@NUMBER",IOP="HOME",DHD="@"
D EN1^DIP K DIR S DIR(0)="Y",DIR("A")="Is this the text on the signed, printed hand receipt",DIR("B")="NO" D ^DIR K DIR
G:$D(DIRUT) EX I 'Y W !!,"Signed copy is not current.",!?5,"Please ask person to sign current version of hand receipt." K DIR S DIR(0)="E" D ^DIR K DIR G EX
K L,DIC,FLDS,FR,TO,BY,IOP,DHD
K DIR S DIR(0)="D^"_$$BEGDATE()_":"_DT_":EX",DIR("A")="Date person signed hard copy hand receipt" D ^DIR K DIR
I 'Y!$D(DIRUT) W !!,"Certification Aborted." G EX
S ENDATE=Y
K DIR S DIR(0)="Y",DIR("A")="OK to certify",DIR("B")="NO" D ^DIR K DIR
G:'Y!$D(DIRUT) EX
D SIG^XUSESIG I X1="" W !,"<Failed Electronic Signature> Certification Aborted." G EX
S ENCNT=0,ENX=""
F S ENX=$O(ENACL(ENX)) Q:ENX="" D
. N ENXSTR S ENXSTR=$G(ENACL(ENX)) Q:ENXSTR=""
. I $L(ENXSTR,",")>0 D
. . F ENJ=1:1 S ENI=$P(ENXSTR,",",ENJ) Q:+ENI'>0 D
. . . S ENDA=^TMP($J,"INDX",ENI) L +^ENG(6916.3,ENDA):$S($G(DILOCKTM)>5:DILOCKTM,1:5) E D MSG^ENTIRT(ENDA,"Certification") Q
. . . S ENZ=$$CERT^ENTIUTL1(ENDA,ENDATE)
. . . S:ENZ ENCNT=ENCNT+1 D:'ENZ MSG2(ENDA)
. . . L -^ENG(6916.3,ENDA)
W !!,ENCNT," assignment records were certified."
K DIR S DIR(0)="E" D ^DIR K DIR
G:Y LOOPST
EX ;
K ^TMP($J,"SCR"),^TMP($J,"INDX"),ENACL
Q
MSG2(ENDA) ;error message on certification failure
N END,ENERR,ENDAC S ENDAC=ENDA_","
D GETS^DIQ(6916.3,ENDAC,".01;1","E","END","ENERR")
W !,"Assignment Equip Entry# ",$G(END(6916.3,ENDAC,.01,"E"))," for ",$G(END(6916.3,ENDAC,1,"E"))," is not active ",!?5,"and was not certified."
Q
BEGDATE() ;Earliest date for certification
N ENDA,ENDATE,ENI,ENJ,ENASGNDT,ENX,ENXSTR
S ENX="",ENDATE=$$FMADD^XLFDT(DT,-359)
F S ENX=$O(ENACL(ENX)) Q:ENX="" D
. S ENXSTR=$G(ENACL(ENX)) Q:ENXSTR=""
. I $L(ENXSTR,",")>0 D
. . F ENJ=1:1 S ENI=$P(ENXSTR,",",ENJ) Q:+ENI'>0 D
. . . S ENDA=^TMP($J,"INDX",ENI),ENASGNDT=$P($P($G(^ENG(6916.3,ENDA,0)),U,3),".")
. . . S:ENASGNDT>ENDATE ENDATE=ENASGNDT
Q ENDATE
;
;ENTIRC
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HENTIRC 3861 printed Oct 16, 2024@17:56:39 Page 2
ENTIRC ;WOIFO/LKG - Certify IT Acceptance ;2/5/08 14:48
+1 ;;7.0;ENGINEERING;**87,89**;Aug 17, 1993;Build 20
IN ;Entry point
+1 NEW D,DIC,DTOUT,DUOUT,DIRUT,DIROUT,DIR,ENDA,ENDAC,ENNAME,ENI,ENJ,ENDATE,ENCNT,ENX,ENZ,X,X1,Y,L,DIC,FLDS,FR,TO,BY,IOP,DHD
LOOPST ;
+1 if '$GET(DT)
SET DT=$$DT^XLFDT()
+2 KILL D,DIC
SET DIC=200
SET DIC(0)="AEMQ"
SET DIC("S")="I $D(^ENG(6916.3,""AOA"",Y))"
+3 DO ^DIC
KILL DIC
IF $DATA(DTOUT)!$DATA(DUOUT)!(Y<1)
GOTO EX
+4 SET ENDA=+Y
SET ENNAME=$PIECE(Y,U,2)
+5 KILL D,^TMP($JOB,"ENITRC"),ENERR
+6 DO FIND^DIC(6916.3,"","@;.01;1;20","PQX",ENDA,"","AOA2","I $P(^(0),U,8)="""",$S($P(^(0),U,5)="""":1,$$FMDIFF^XLFDT(DT,$P(^(0),U,5))>359:1,1:0)","","^TMP($J,""ENITRC"")","ENERR")
+7 IF $PIECE($GET(^TMP($JOB,"ENITRC","DILIST",0)),U)'>0
WRITE !!,"There are no unaccepted IT responsibilities to be certified."
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
KILL ^TMP($JOB,"ENITRC")
if 'Y
GOTO EX
GOTO LOOPST
+8 KILL ^TMP($JOB,"SCR"),^TMP($JOB,"INDX"),ENACL
WRITE !
+9 SET ^TMP($JOB,"SCR")=$PIECE(^TMP($JOB,"ENITRC","DILIST",0),U)_"^IT RESPONSIBILITIES TO CERTIFY FOR "_ENNAME
+10 SET ^TMP($JOB,"SCR",0)="5;9;ENTRY #^15;20;MFG EQUIP NAME^37;25;MODEL^65;14;SERIAL#"
+11 SET ENI=0
+12 FOR
SET ENI=$ORDER(^TMP($JOB,"ENITRC","DILIST",ENI))
if +ENI'>0
QUIT
Begin DoDot:1
+13 NEW ENX,END,ENERR
SET ENX=$GET(^TMP($JOB,"ENITRC","DILIST",ENI,0))
+14 SET ENDAC=$PIECE(ENX,U,2)_","
DO GETS^DIQ(6914,ENDAC,"3;4;5","E","END","ENERR")
+15 SET ^TMP($JOB,"SCR",ENI)=$PIECE(ENX,U,2)_U_$EXTRACT($GET(END(6914,ENDAC,3,"E")),1,20)_U_$GET(END(6914,ENDAC,4,"E"))_U_$GET(END(6914,ENDAC,5,"E"))
+16 SET ^TMP($JOB,"INDX",ENI)=$PIECE(ENX,U)
End DoDot:1
+17 KILL ^TMP($JOB,"ENITRC")
+18 DO EN2^ENPLS2(1)
if '$DATA(ENACL)
GOTO EX
+19 KILL DIR
SET DIR(0)="Y"
SET DIR("A")="OK to continue"
SET DIR("B")="NO"
DO ^DIR
KILL DIR
+20 if 'Y!$DATA(DIRUT)
GOTO EX
+21 SET ENDA=$ORDER(^ENG(6916.2,"@"),-1)
+22 IF '$$CMP^XUSESIG1($PIECE($GET(^ENG(6916.2,ENDA,0)),U,3),$NAME(^ENG(6916.2,ENDA,1)))
WRITE !!,"Hand receipt text is corrupted - Please contact EPS AEMS/MERS support"
GOTO EX
+23 KILL L,DIC,FLDS,FR,TO,BY,IOP,DHD
+24 SET L=0
SET DIC=6916.2
SET FLDS=1
SET FR=ENDA
SET TO=ENDA
SET BY="@NUMBER"
SET IOP="HOME"
SET DHD="@"
+25 DO EN1^DIP
KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Is this the text on the signed, printed hand receipt"
SET DIR("B")="NO"
DO ^DIR
KILL DIR
+26 if $DATA(DIRUT)
GOTO EX
IF 'Y
WRITE !!,"Signed copy is not current.",!?5,"Please ask person to sign current version of hand receipt."
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
GOTO EX
+27 KILL L,DIC,FLDS,FR,TO,BY,IOP,DHD
+28 KILL DIR
SET DIR(0)="D^"_$$BEGDATE()_":"_DT_":EX"
SET DIR("A")="Date person signed hard copy hand receipt"
DO ^DIR
KILL DIR
+29 IF 'Y!$DATA(DIRUT)
WRITE !!,"Certification Aborted."
GOTO EX
+30 SET ENDATE=Y
+31 KILL DIR
SET DIR(0)="Y"
SET DIR("A")="OK to certify"
SET DIR("B")="NO"
DO ^DIR
KILL DIR
+32 if 'Y!$DATA(DIRUT)
GOTO EX
+33 DO SIG^XUSESIG
IF X1=""
WRITE !,"<Failed Electronic Signature> Certification Aborted."
GOTO EX
+34 SET ENCNT=0
SET ENX=""
+35 FOR
SET ENX=$ORDER(ENACL(ENX))
if ENX=""
QUIT
Begin DoDot:1
+36 NEW ENXSTR
SET ENXSTR=$GET(ENACL(ENX))
if ENXSTR=""
QUIT
+37 IF $LENGTH(ENXSTR,",")>0
Begin DoDot:2
+38 FOR ENJ=1:1
SET ENI=$PIECE(ENXSTR,",",ENJ)
if +ENI'>0
QUIT
Begin DoDot:3
+39 SET ENDA=^TMP($JOB,"INDX",ENI)
LOCK +^ENG(6916.3,ENDA):$SELECT($GET(DILOCKTM)>5:DILOCKTM,1:5)
IF '$TEST
DO MSG^ENTIRT(ENDA,"Certification")
QUIT
+40 SET ENZ=$$CERT^ENTIUTL1(ENDA,ENDATE)
+41 if ENZ
SET ENCNT=ENCNT+1
if 'ENZ
DO MSG2(ENDA)
+42 LOCK -^ENG(6916.3,ENDA)
End DoDot:3
End DoDot:2
End DoDot:1
+43 WRITE !!,ENCNT," assignment records were certified."
+44 KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
+45 if Y
GOTO LOOPST
EX ;
+1 KILL ^TMP($JOB,"SCR"),^TMP($JOB,"INDX"),ENACL
+2 QUIT
MSG2(ENDA) ;error message on certification failure
+1 NEW END,ENERR,ENDAC
SET ENDAC=ENDA_","
+2 DO GETS^DIQ(6916.3,ENDAC,".01;1","E","END","ENERR")
+3 WRITE !,"Assignment Equip Entry# ",$GET(END(6916.3,ENDAC,.01,"E"))," for ",$GET(END(6916.3,ENDAC,1,"E"))," is not active ",!?5,"and was not certified."
+4 QUIT
BEGDATE() ;Earliest date for certification
+1 NEW ENDA,ENDATE,ENI,ENJ,ENASGNDT,ENX,ENXSTR
+2 SET ENX=""
SET ENDATE=$$FMADD^XLFDT(DT,-359)
+3 FOR
SET ENX=$ORDER(ENACL(ENX))
if ENX=""
QUIT
Begin DoDot:1
+4 SET ENXSTR=$GET(ENACL(ENX))
if ENXSTR=""
QUIT
+5 IF $LENGTH(ENXSTR,",")>0
Begin DoDot:2
+6 FOR ENJ=1:1
SET ENI=$PIECE(ENXSTR,",",ENJ)
if +ENI'>0
QUIT
Begin DoDot:3
+7 SET ENDA=^TMP($JOB,"INDX",ENI)
SET ENASGNDT=$PIECE($PIECE($GET(^ENG(6916.3,ENDA,0)),U,3),".")
+8 if ENASGNDT>ENDATE
SET ENDATE=ENASGNDT
End DoDot:3
End DoDot:2
End DoDot:1
+9 QUIT ENDATE
+10 ;
+11 ;ENTIRC
