PRCNTICM.m

PRCNTICM ;SSI/SEB-CMR Official Review/Approval for Turnin ;[ 03/13/97  10:28 AM ]

 ;;1.0;PRCN;**2,3,14,15**;Sep 13, 1996

EN S PRCNC=DUZ D CMR^PRCNCMR K PRCNC

 S DIC("S")="S ST=$P(^(0),U,7),CMRZ=$P(^(0),U,16) I ST=3&($D(PRCNCMR(CMRZ)))"

 S DIC="^PRCN(413.1,",DIC(0)="AEQZ" D ^DIC G EXIT:+Y<0 K DIC("S")

 S (DA,PRCNTDA,IN)=+Y,PRCNUSR=0 D SETUP^PRCNTIPR

 S DIE=413.1,DR="[PRCNTICMR]" D ^DIE

 I $D(^PRCN(413.1,DA,2)) S GLO=413.1 D MES  ; PRCN*1.0*15

 ;  Set the turn-in date in 6914

 S PRCNN=0 F  S PRCNN=$O(^PRCN(413.1,PRCNTDA,1,PRCNN)) Q:'PRCNN  D

 . S DA=$P(^PRCN(413.1,PRCNTDA,1,PRCNN,0),U)

 . S PRCNFAP=$$CHKFA^ENFAUTL(DA) Q:$P(PRCNFAP,U)=1

 . S (DIE,DIC)=6914,DR="20.5////^S X=DT" D ^DIE

EXT K DIC,DIE,DA,DR,IN,PRCNUSR,Y,PRCNCMR,PRCN,PRCNTDA,PRCNC,PRCNN,PRCNFAP

 G EN

MES ;  Send mail message when CMR Official has not approved request

 N GLO

 S GLO=413.1

 S XMB(1)=$P(^PRCN(413.1,DA,0),U),XMDUZ=DUZ

 S XMB="PRCNCMR2",XMY($P(^PRCN(413.1,DA,0),U,2))="",XMY(XMDUZ)=""

 S CMRDA=$P(^PRCN(413.1,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.1,DA,2,0)),U,3),XMTEXT="MSG("

 I NL'="" F I=1:1:NL S MSG(I)=$G(^PRCN(413.1,DA,2,I,0))

 D ^XMB

 K MSG,NL,XMB,XMTEXT,I,XMY,XMDUZ

 Q

EXIT K DIC,DIE,DA,DR,IN,PRCNUSR,Y,PRCNCMR,PRCN,PRCNTDA,PRCNC,PRCNN,PRCNFAP

 K CMRZ,PRCNCM

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PRCNTICM   1424     printed  Apr 09, 2024@20:59:46                                                                                                                                                                                                    Page 2

PRCNTICM  ;SSI/SEB-CMR Official Review/Approval for Turnin ;[ 03/13/97  10:28 AM ]

 +1       ;;1.0;PRCN;**2,3,14,15**;Sep 13, 1996

EN         SET PRCNC=DUZ

           DO CMR^PRCNCMR

           KILL PRCNC

 +1        SET DIC("S")="S ST=$P(^(0),U,7),CMRZ=$P(^(0),U,16) I ST=3&($D(PRCNCMR(CMRZ)))"

 +2        SET DIC="^PRCN(413.1,"

           SET DIC(0)="AEQZ"

           DO ^DIC

           if +Y<0

               GOTO EXIT

           KILL DIC("S")

 +3        SET (DA,PRCNTDA,IN)=+Y

           SET PRCNUSR=0

           DO SETUP^PRCNTIPR

 +4        SET DIE=413.1

           SET DR="[PRCNTICMR]"

           DO ^DIE

 +5       ; PRCN*1.0*15

           IF $DATA(^PRCN(413.1,DA,2))

               SET GLO=413.1

               DO MES

 +6       ;  Set the turn-in date in 6914

 +7        SET PRCNN=0

           FOR 

               SET PRCNN=$ORDER(^PRCN(413.1,PRCNTDA,1,PRCNN))

               if 'PRCNN

                   QUIT 

               Begin DoDot:1

 +8                SET DA=$PIECE(^PRCN(413.1,PRCNTDA,1,PRCNN,0),U)

 +9                SET PRCNFAP=$$CHKFA^ENFAUTL(DA)

                   if $PIECE(PRCNFAP,U)=1

                       QUIT 

 +10               SET (DIE,DIC)=6914

                   SET DR="20.5////^S X=DT"

                   DO ^DIE

               End DoDot:1

EXT        KILL DIC,DIE,DA,DR,IN,PRCNUSR,Y,PRCNCMR,PRCN,PRCNTDA,PRCNC,PRCNN,PRCNFAP

 +1        GOTO EN

MES       ;  Send mail message when CMR Official has not approved request

 +1        NEW GLO

 +2        SET GLO=413.1

 +3        SET XMB(1)=$PIECE(^PRCN(413.1,DA,0),U)

           SET XMDUZ=DUZ

 +4        SET XMB="PRCNCMR2"

           SET XMY($PIECE(^PRCN(413.1,DA,0),U,2))=""

           SET XMY(XMDUZ)=""

 +5        SET CMRDA=$PIECE(^PRCN(413.1,DA,0),U,16)

 +6        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))=""

 +7       ;  Append the explanation text

 +8        SET NL=$PIECE($GET(^PRCN(413.1,DA,2,0)),U,3)

           SET XMTEXT="MSG("

 +9        IF NL'=""

               FOR I=1:1:NL

                   SET MSG(I)=$GET(^PRCN(413.1,DA,2,I,0))

 +10       DO ^XMB

 +11       KILL MSG,NL,XMB,XMTEXT,I,XMY,XMDUZ

 +12       QUIT 

EXIT       KILL DIC,DIE,DA,DR,IN,PRCNUSR,Y,PRCNCMR,PRCN,PRCNTDA,PRCNC,PRCNN,PRCNFAP

 +1        KILL CMRZ,PRCNCM

 +2        QUIT