PRCNCMR ;SSI/ALA-CMR Official ;[ 03/13/97 10:29 AM ]
;;1.0;PRCN;**3,14**;Sep 13, 1996
REV ; Review equipment requests
S PRCNC=DUZ D CMR K PRCNC
S DIC="^PRCN(413,",DIC(0)="AEQZ"
S DIC("S")="S ST=$P(^(0),U,7),CMRZ=$P(^(0),U,16) I ((ST=3)!(ST=5)!(ST=45))&($D(PRCNCMR(CMRZ)))"
D ^DIC G EXIT:Y<0 K DIC("S")
S (IN,DA)=+Y,PRCNUSR=0,DIE=413 D SETUP^PRCNPRNT
S PRCNST=$P(^PRCN(413,IN,0),U,7)
I PRCNST'=45 S DR="[PRCNCMR]"
I PRCNST=45 S DR="75"
D ^DIE I PRCNST=45 D G REV
. I $P(^PRCN(413,DA,2),U,17)="Y" S DR="6////^S X=39;7////^S X=DT"
. I $P(^PRCN(413,DA,2),U,17)="N" S DR="6////^S X=4;7////^S X=DT;77////^S X=45"
. D ^DIE,EXIT
I $P(^PRCN(413,IN,0),U,9)="R" D
. ; If replacment request copy CMR fields into turnin request
. S DA=$P(^PRCN(413,IN,0),U,11)
. S CPRV=$P($G(^PRCN(413,IN,2)),U,16),$P(^PRCN(413.1,DA,0),U,10)=CPRV
. F I=1:1:$P($G(^PRCN(413,IN,15,0)),U,4) S ^PRCN(413.1,DA,2,I,0)=$G(^PRCN(413,IN,15,I,0))
. S ^PRCN(413.1,DA,2,0)="^^"_I_U_I_DT_U
. I CPRV="Y" S DIE=413.1,DR="6////^S X=6;7////^S X=DT" D ^DIE
. I CPRV="N" S DIE=413.1,DR="6////^S X=4;7////^S X=DT" D ^DIE
D EXIT
G REV
EXIT K DA,DIC,DIE,DR,I,IN,PRCNUSR,PRCNCMR,PRCN,CPRV,ST,PRCNST,PRCNTY,STA,D
K %,C,D0,J,GLO,FAIL,PRCNDEF,LPRI,OLDPRI,PRIMAX,SERV,CMRZ,JJ
Q
MES ; Send mail message when CMR Official has not approved request
S XMB(1)=$P(^PRCN(413,DA,0),U),XMB="PRCNCMR1",XMDUZ=DUZ,XMY(XMDUZ)=""
S XMY($P(^PRCN(413,DA,0),U,2))=""
S CMRDA=$P(^PRCN(413,DA,0),U,16)
I CMRDA'="",$D(^ENG(6914.1,CMRDA,0)),($P(^ENG(6914.1,CMRDA,0),U,2)'="") S XMY($P(^ENG(6914.1,CMRDA,0),U,2))=""
; Append the explanation text
S NL=$P($G(^PRCN(413,DA,15,0)),U,3),XMTEXT="MSG("
I NL'="" F I=1:1:NL S MSG(I)=$G(^PRCN(413,DA,15,I,0))
D ^XMB
K XMB,NL,MSG,XMTEXT,XMY,XMDUZ
Q
CMR S (PRCNCMR,PRCN)=""
F S PRCN=$O(^ENG(6914.1,"C",PRCNC,PRCN)) Q:PRCN="" S PRCNCMR(PRCN)=""
F S PRCN=$O(^ENG(6914.1,"D",PRCNC,PRCN)) Q:PRCN="" S PRCNCMR(PRCN)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCNCMR 1965 printed Apr 09, 2024@21:00:01 Page 2
PRCNCMR ;SSI/ALA-CMR Official ;[ 03/13/97 10:29 AM ]
+1 ;;1.0;PRCN;**3,14**;Sep 13, 1996
REV ; Review equipment requests
+1 SET PRCNC=DUZ
DO CMR
KILL PRCNC
+2 SET DIC="^PRCN(413,"
SET DIC(0)="AEQZ"
+3 SET DIC("S")="S ST=$P(^(0),U,7),CMRZ=$P(^(0),U,16) I ((ST=3)!(ST=5)!(ST=45))&($D(PRCNCMR(CMRZ)))"
+4 DO ^DIC
if Y<0
GOTO EXIT
KILL DIC("S")
+5 SET (IN,DA)=+Y
SET PRCNUSR=0
SET DIE=413
DO SETUP^PRCNPRNT
+6 SET PRCNST=$PIECE(^PRCN(413,IN,0),U,7)
+7 IF PRCNST'=45
SET DR="[PRCNCMR]"
+8 IF PRCNST=45
SET DR="75"
+9 DO ^DIE
IF PRCNST=45
Begin DoDot:1
+10 IF $PIECE(^PRCN(413,DA,2),U,17)="Y"
SET DR="6////^S X=39;7////^S X=DT"
+11 IF $PIECE(^PRCN(413,DA,2),U,17)="N"
SET DR="6////^S X=4;7////^S X=DT;77////^S X=45"
+12 DO ^DIE
DO EXIT
End DoDot:1
GOTO REV
+13 IF $PIECE(^PRCN(413,IN,0),U,9)="R"
Begin DoDot:1
+14 ; If replacment request copy CMR fields into turnin request
+15 SET DA=$PIECE(^PRCN(413,IN,0),U,11)
+16 SET CPRV=$PIECE($GET(^PRCN(413,IN,2)),U,16)
SET $PIECE(^PRCN(413.1,DA,0),U,10)=CPRV
+17 FOR I=1:1:$PIECE($GET(^PRCN(413,IN,15,0)),U,4)
SET ^PRCN(413.1,DA,2,I,0)=$GET(^PRCN(413,IN,15,I,0))
+18 SET ^PRCN(413.1,DA,2,0)="^^"_I_U_I_DT_U
+19 IF CPRV="Y"
SET DIE=413.1
SET DR="6////^S X=6;7////^S X=DT"
DO ^DIE
+20 IF CPRV="N"
SET DIE=413.1
SET DR="6////^S X=4;7////^S X=DT"
DO ^DIE
End DoDot:1
+21 DO EXIT
+22 GOTO REV
EXIT KILL DA,DIC,DIE,DR,I,IN,PRCNUSR,PRCNCMR,PRCN,CPRV,ST,PRCNST,PRCNTY,STA,D
+1 KILL %,C,D0,J,GLO,FAIL,PRCNDEF,LPRI,OLDPRI,PRIMAX,SERV,CMRZ,JJ
+2 QUIT
MES ; Send mail message when CMR Official has not approved request
+1 SET XMB(1)=$PIECE(^PRCN(413,DA,0),U)
SET XMB="PRCNCMR1"
SET XMDUZ=DUZ
SET XMY(XMDUZ)=""
+2 SET XMY($PIECE(^PRCN(413,DA,0),U,2))=""
+3 SET CMRDA=$PIECE(^PRCN(413,DA,0),U,16)
+4 IF CMRDA'=""
IF $DATA(^ENG(6914.1,CMRDA,0))
IF ($PIECE(^ENG(6914.1,CMRDA,0),U,2)'="")
SET XMY($PIECE(^ENG(6914.1,CMRDA,0),U,2))=""
+5 ; Append the explanation text
+6 SET NL=$PIECE($GET(^PRCN(413,DA,15,0)),U,3)
SET XMTEXT="MSG("
+7 IF NL'=""
FOR I=1:1:NL
SET MSG(I)=$GET(^PRCN(413,DA,15,I,0))
+8 DO ^XMB
+9 KILL XMB,NL,MSG,XMTEXT,XMY,XMDUZ
+10 QUIT
CMR SET (PRCNCMR,PRCN)=""
+1 FOR
SET PRCN=$ORDER(^ENG(6914.1,"C",PRCNC,PRCN))
if PRCN=""
QUIT
SET PRCNCMR(PRCN)=""
+2 FOR
SET PRCN=$ORDER(^ENG(6914.1,"D",PRCNC,PRCN))
if PRCN=""
QUIT
SET PRCNCMR(PRCN)=""
+3 QUIT
