ENTIRX ;WOIFO/LKG - TRANSFER RESPONSIBILITY ;2/5/08 14:58
;;7.0;ENGINEERING;**87,89**;Aug 17, 1993;Build 20
TERMLST ;Entry for transfer processing
N DA,DIR,DIROUT,DIRUT,DTOUT,DUOUT,DIC,D,ENA,ENACL,ENCNT,ENCNT2,ENDA,ENMETHOD,ENNAME,ENNBR,ENPER,ENRES,ENERR,ENX,ENI,ENJ,X,X1,Y
LSTSTART S DIR(0)="S^E:EQUIPMENT;P:PERSON",DIR("A")="Specify method for selecting IT assignments"
D ^DIR K DIR G:$D(DIRUT)!$D(DIROUT)!$D(DTOUT)!$D(DUOUT) LSTEXIT
S ENMETHOD=Y
I ENMETHOD="E" D G:$D(ENERR) LSTEXIT
. N D,DIC S DIC("S")="I $D(^ENG(6916.3,""AEA"",Y))" D GETEQ^ENUTL
. I $D(DTOUT)!$D(DUOUT)!(Y<1) S ENERR=1 Q
. S ENDA=+Y
. K DIC,D,^TMP($J,"ENITTR"),ENERR
. D FIND^DIC(6916.3,"","@;.01;1;20","PQX",ENDA,"","AEA","I $P(^(0),U,8)=""""","","^TMP($J,""ENITTR"")","ENERR")
I ENMETHOD="P" D G:$D(ENERR) LSTEXIT
. N D,DIC S DIC=200,DIC(0)="AEMQ",DIC("S")="I $D(^ENG(6916.3,""AOA"",Y))"
. D ^DIC I $D(DTOUT)!$D(DUOUT)!(Y<1) S ENERR=1 Q
. S ENDA=+Y
. K DIC,D,^TMP($J,"ENITTR"),ENERR
. D FIND^DIC(6916.3,"","@;.01;1;20","PQX",ENDA,"","AOA2","I $P(^(0),U,8)=""""","","^TMP($J,""ENITTR"")","ENERR")
I $P($G(^TMP($J,"ENITTR","DILIST",0)),U)'>0 W !!,"There are no active responsibilities for this "_$S(ENMETHOD="E":"equipment",ENMETHOD="P":"person",1:"")_"." K DIR S DIR(0)="E" D ^DIR K DIR K ^TMP($J,"ENITTR") G LSTEXIT:'Y,LSTSTART
K ^TMP($J,"SCR"),^TMP($J,"INDX"),ENACL
S ^TMP($J,"SCR")=$P(^TMP($J,"ENITTR","DILIST",0),U)_"^ACTIVE IT RESPONSIBILITIES"
S ^TMP($J,"SCR",0)="5;9;ENTRY #^15;20;MFG EQUIP NAME^37;30;OWNER^69;10;STATUS"
S ENI=0
F S ENI=$O(^TMP($J,"ENITTR","DILIST",ENI)) Q:+ENI'>0 D
. N ENX S ENX=$G(^TMP($J,"ENITTR","DILIST",ENI,0))
. S ^TMP($J,"SCR",ENI)=$P(ENX,U,2)_U_$E($$GET1^DIQ(6914,$P(ENX,U,2)_",",3),1,20)_U_$P(ENX,U,3,4)
. S ^TMP($J,"INDX",ENI)=$P(ENX,U)
K ^TMP($J,"ENITTR")
D EN2^ENPLS2(1)
I '$D(ENACL)!$D(DIRUT)!$D(DIROUT) K ^TMP($J,"SCR"),^TMP($J,"INDX") G LSTEXIT
ASKNAME K DIC S DIC=200,DIC(0)="AEMQ",DIC("A")="Select person for new assignment: "
D ^DIC I +Y<1!$D(DTOUT)!$D(DUOUT) G LSTEXIT
S ENPER=+Y,ENNAME=$P(Y,U,2) K DIR S DIR(0)="Y",DIR("A")="Assign responsibility to "_ENNAME,DIR("B")="NO"
D ^DIR G LSTEXIT:$D(DIRUT),ASKNAME:'Y
S DIR(0)="Y",DIR("A")="OK to transfer assignments",DIR("B")="NO" D ^DIR K DIR
G:'Y!$D(DIRUT) LSTEXIT W !
S ENCNT=0,ENCNT2=0,ENX="" K ENA K ^TMP($J,"ENSIGN")
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 DA=^TMP($J,"INDX",ENI) L +^ENG(6916.3,DA):$S($G(DILOCKTM)>5:DILOCKTM,1:5) E D MSG^ENTIRT(DA,"Transfer") Q
. . . S X=$$TERM^ENTIUTL1(DA)
. . . L -^ENG(6916.3,DA)
. . . S ENCNT=ENCNT+1
. . . S ENNBR=$P($G(^ENG(6916.3,DA,0)),U) Q:'ENNBR
. . . I '$D(ENA(ENNBR)) S ENRES=$$ASGN^ENTIUTL1(ENNBR,ENPER),ENA(ENNBR)=ENRES S:ENRES ENCNT2=ENCNT2+1 W:ENRES=0 !,ENNBR," is already assigned to ",ENNAME,"." S:(ENPER=DUZ)&ENRES ^TMP($J,"ENSIGN",ENRES)=""
W !!,ENCNT," IT responsibilities were terminated.",!,ENCNT2," assignments were created." K DIR S DIR(0)="E" D ^DIR K DIR K ^TMP($J,"SCR"),^TMP($J,"INDX") G:'Y LSTEXIT
I ENPER=DUZ,$$SIGNOK() D
. N L,DIC,FLDS,FR,TO,BY,IOP,DHD,ENMSG
. S DA=$O(^ENG(6916.2,"@"),-1)
. I '$$CMP^XUSESIG1($P($G(^ENG(6916.2,DA,0)),U,3),$NAME(^ENG(6916.2,DA,1))) W !!,"Hand receipt text is corrupted - Please contact EPS AEMS/MERS support." Q
. S L=0,DIC=6916.2,FLDS=1,FR=DA,TO=DA,BY="@NUMBER",IOP="HOME",DHD="@"
. D EN1^DIP
. K DIR S DIR(0)="Y",DIR("A")="OK to sign",DIR("B")="NO" D ^DIR K DIR
. Q:'Y!$D(DIRUT)
. D SIG^XUSESIG I X1="" W !,"<Invalid Electronic Signature> Signing Aborted." Q
. S ENDA="",ENCNT=0
. F S ENDA=$O(^TMP($J,"ENSIGN",ENDA)) Q:ENDA="" D
. . L +^ENG(6916.3,ENDA):$S($G(DILOCKTM)>5:DILOCKTM,1:5) E D MSG^ENTIRT(ENDA,"Signature") Q
. . I $$SIGN^ENTIUTL1(ENDA) S ENCNT=ENCNT+1 K ^TMP($J,"ENSIGN",ENDA)
. . L -^ENG(6916.3,ENDA)
. W !!,ENCNT," assignment records were signed."
. S ENDA=""
. F S ENDA=$O(^TMP($J,"ENSIGN",ENDA)) Q:ENDA="" D
. . 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"))," was not signed."
. . K ^TMP($J,"ENSIGN",ENDA)
G LSTSTART:'$D(DIRUT)
LSTEXIT ;
K ^TMP($J,"ENSIGN"),^TMP($J,"ENITTR"),^TMP($J,"INDX"),^TMP($J,"SCR")
Q
SIGNOK() ;Ask if want to sign for equipment
K DIR S DIR(0)="Y",DIR("A")="Do you want to sign to accept responsibility now",DIR("B")="NO"
D ^DIR K DIR
Q Y
;
;ENTIRX
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HENTIRX 4599 printed Nov 22, 2024@17:06:10 Page 2
ENTIRX ;WOIFO/LKG - TRANSFER RESPONSIBILITY ;2/5/08 14:58
+1 ;;7.0;ENGINEERING;**87,89**;Aug 17, 1993;Build 20
TERMLST ;Entry for transfer processing
+1 NEW DA,DIR,DIROUT,DIRUT,DTOUT,DUOUT,DIC,D,ENA,ENACL,ENCNT,ENCNT2,ENDA,ENMETHOD,ENNAME,ENNBR,ENPER,ENRES,ENERR,ENX,ENI,ENJ,X,X1,Y
LSTSTART SET DIR(0)="S^E:EQUIPMENT;P:PERSON"
SET DIR("A")="Specify method for selecting IT assignments"
+1 DO ^DIR
KILL DIR
if $DATA(DIRUT)!$DATA(DIROUT)!$DATA(DTOUT)!$DATA(DUOUT)
GOTO LSTEXIT
+2 SET ENMETHOD=Y
+3 IF ENMETHOD="E"
Begin DoDot:1
+4 NEW D,DIC
SET DIC("S")="I $D(^ENG(6916.3,""AEA"",Y))"
DO GETEQ^ENUTL
+5 IF $DATA(DTOUT)!$DATA(DUOUT)!(Y<1)
SET ENERR=1
QUIT
+6 SET ENDA=+Y
+7 KILL DIC,D,^TMP($JOB,"ENITTR"),ENERR
+8 DO FIND^DIC(6916.3,"","@;.01;1;20","PQX",ENDA,"","AEA","I $P(^(0),U,8)=""""","","^TMP($J,""ENITTR"")","ENERR")
End DoDot:1
if $DATA(ENERR)
GOTO LSTEXIT
+9 IF ENMETHOD="P"
Begin DoDot:1
+10 NEW D,DIC
SET DIC=200
SET DIC(0)="AEMQ"
SET DIC("S")="I $D(^ENG(6916.3,""AOA"",Y))"
+11 DO ^DIC
IF $DATA(DTOUT)!$DATA(DUOUT)!(Y<1)
SET ENERR=1
QUIT
+12 SET ENDA=+Y
+13 KILL DIC,D,^TMP($JOB,"ENITTR"),ENERR
+14 DO FIND^DIC(6916.3,"","@;.01;1;20","PQX",ENDA,"","AOA2","I $P(^(0),U,8)=""""","","^TMP($J,""ENITTR"")","ENERR")
End DoDot:1
if $DATA(ENERR)
GOTO LSTEXIT
+15 IF $PIECE($GET(^TMP($JOB,"ENITTR","DILIST",0)),U)'>0
WRITE !!,"There are no active responsibilities for this "_$SELECT(ENMETHOD="E":"equipment",ENMETHOD="P":"person",1:"")_"."
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
KILL ^TMP($JOB,"ENITTR")
if 'Y
GOTO LSTEXIT
GOTO LSTSTART
+16 KILL ^TMP($JOB,"SCR"),^TMP($JOB,"INDX"),ENACL
+17 SET ^TMP($JOB,"SCR")=$PIECE(^TMP($JOB,"ENITTR","DILIST",0),U)_"^ACTIVE IT RESPONSIBILITIES"
+18 SET ^TMP($JOB,"SCR",0)="5;9;ENTRY #^15;20;MFG EQUIP NAME^37;30;OWNER^69;10;STATUS"
+19 SET ENI=0
+20 FOR
SET ENI=$ORDER(^TMP($JOB,"ENITTR","DILIST",ENI))
if +ENI'>0
QUIT
Begin DoDot:1
+21 NEW ENX
SET ENX=$GET(^TMP($JOB,"ENITTR","DILIST",ENI,0))
+22 SET ^TMP($JOB,"SCR",ENI)=$PIECE(ENX,U,2)_U_$EXTRACT($$GET1^DIQ(6914,$PIECE(ENX,U,2)_",",3),1,20)_U_$PIECE(ENX,U,3,4)
+23 SET ^TMP($JOB,"INDX",ENI)=$PIECE(ENX,U)
End DoDot:1
+24 KILL ^TMP($JOB,"ENITTR")
+25 DO EN2^ENPLS2(1)
+26 IF '$DATA(ENACL)!$DATA(DIRUT)!$DATA(DIROUT)
KILL ^TMP($JOB,"SCR"),^TMP($JOB,"INDX")
GOTO LSTEXIT
ASKNAME KILL DIC
SET DIC=200
SET DIC(0)="AEMQ"
SET DIC("A")="Select person for new assignment: "
+1 DO ^DIC
IF +Y<1!$DATA(DTOUT)!$DATA(DUOUT)
GOTO LSTEXIT
+2 SET ENPER=+Y
SET ENNAME=$PIECE(Y,U,2)
KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Assign responsibility to "_ENNAME
SET DIR("B")="NO"
+3 DO ^DIR
if $DATA(DIRUT)
GOTO LSTEXIT
if 'Y
GOTO ASKNAME
+4 SET DIR(0)="Y"
SET DIR("A")="OK to transfer assignments"
SET DIR("B")="NO"
DO ^DIR
KILL DIR
+5 if 'Y!$DATA(DIRUT)
GOTO LSTEXIT
WRITE !
+6 SET ENCNT=0
SET ENCNT2=0
SET ENX=""
KILL ENA
KILL ^TMP($JOB,"ENSIGN")
+7 FOR
SET ENX=$ORDER(ENACL(ENX))
if ENX=""
QUIT
Begin DoDot:1
+8 NEW ENXSTR
+9 SET ENXSTR=$GET(ENACL(ENX))
if ENXSTR=""
QUIT
+10 IF $LENGTH(ENXSTR,",")>0
Begin DoDot:2
+11 FOR ENJ=1:1
SET ENI=$PIECE(ENXSTR,",",ENJ)
if +ENI'>0
QUIT
Begin DoDot:3
+12 SET DA=^TMP($JOB,"INDX",ENI)
LOCK +^ENG(6916.3,DA):$SELECT($GET(DILOCKTM)>5:DILOCKTM,1:5)
IF '$TEST
DO MSG^ENTIRT(DA,"Transfer")
QUIT
+13 SET X=$$TERM^ENTIUTL1(DA)
+14 LOCK -^ENG(6916.3,DA)
+15 SET ENCNT=ENCNT+1
+16 SET ENNBR=$PIECE($GET(^ENG(6916.3,DA,0)),U)
if 'ENNBR
QUIT
+17 IF '$DATA(ENA(ENNBR))
SET ENRES=$$ASGN^ENTIUTL1(ENNBR,ENPER)
SET ENA(ENNBR)=ENRES
if ENRES
SET ENCNT2=ENCNT2+1
if ENRES=0
WRITE !,ENNBR," is already assigned to ",ENNAME,"."
if (ENPER=DUZ)&ENRES
SET ^TMP($JOB,"ENSIGN",ENRES)=""
End DoDot:3
End DoDot:2
End DoDot:1
+18 WRITE !!,ENCNT," IT responsibilities were terminated.",!,ENCNT2," assignments were created."
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
KILL ^TMP($JOB,"SCR"),^TMP($JOB,"INDX")
if 'Y
GOTO LSTEXIT
+19 IF ENPER=DUZ
IF $$SIGNOK()
Begin DoDot:1
+20 NEW L,DIC,FLDS,FR,TO,BY,IOP,DHD,ENMSG
+21 SET DA=$ORDER(^ENG(6916.2,"@"),-1)
+22 IF '$$CMP^XUSESIG1($PIECE($GET(^ENG(6916.2,DA,0)),U,3),$NAME(^ENG(6916.2,DA,1)))
WRITE !!,"Hand receipt text is corrupted - Please contact EPS AEMS/MERS support."
QUIT
+23 SET L=0
SET DIC=6916.2
SET FLDS=1
SET FR=DA
SET TO=DA
SET BY="@NUMBER"
SET IOP="HOME"
SET DHD="@"
+24 DO EN1^DIP
+25 KILL DIR
SET DIR(0)="Y"
SET DIR("A")="OK to sign"
SET DIR("B")="NO"
DO ^DIR
KILL DIR
+26 if 'Y!$DATA(DIRUT)
QUIT
+27 DO SIG^XUSESIG
IF X1=""
WRITE !,"<Invalid Electronic Signature> Signing Aborted."
QUIT
+28 SET ENDA=""
SET ENCNT=0
+29 FOR
SET ENDA=$ORDER(^TMP($JOB,"ENSIGN",ENDA))
if ENDA=""
QUIT
Begin DoDot:2
+30 LOCK +^ENG(6916.3,ENDA):$SELECT($GET(DILOCKTM)>5:DILOCKTM,1:5)
IF '$TEST
DO MSG^ENTIRT(ENDA,"Signature")
QUIT
+31 IF $$SIGN^ENTIUTL1(ENDA)
SET ENCNT=ENCNT+1
KILL ^TMP($JOB,"ENSIGN",ENDA)
+32 LOCK -^ENG(6916.3,ENDA)
End DoDot:2
+33 WRITE !!,ENCNT," assignment records were signed."
+34 SET ENDA=""
+35 FOR
SET ENDA=$ORDER(^TMP($JOB,"ENSIGN",ENDA))
if ENDA=""
QUIT
Begin DoDot:2
+36 NEW END,ENERR,ENDAC
SET ENDAC=ENDA_","
DO GETS^DIQ(6916.3,ENDAC,".01;1","E","END","ENERR")
+37 WRITE !,"Assignment Equip Entry# ",$GET(END(6916.3,ENDAC,.01,"E"))," for ",$GET(END(6916.3,ENDAC,1,"E"))," was not signed."
+38 KILL ^TMP($JOB,"ENSIGN",ENDA)
End DoDot:2
End DoDot:1
+39 if '$DATA(DIRUT)
GOTO LSTSTART
LSTEXIT ;
+1 KILL ^TMP($JOB,"ENSIGN"),^TMP($JOB,"ENITTR"),^TMP($JOB,"INDX"),^TMP($JOB,"SCR")
+2 QUIT
SIGNOK() ;Ask if want to sign for equipment
+1 KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Do you want to sign to accept responsibility now"
SET DIR("B")="NO"
+2 DO ^DIR
KILL DIR
+3 QUIT Y
+4 ;
+5 ;ENTIRX
