GECSSDCT ;WISC/RFJ-dct accept,reject message utilities ;25 Apr 94
;;2.0;GCS;;MAR 14, 1995
Q
;
;
SETCODE(DA,CODE) ; set event code to be called for accept/reject msg
; da = stack internal entry number
; code = D LABEL^ROUTINE
; when the code gets called, it will pass the 1) document number,
; 2) 'A'ccepted or 'R'ejected, 3) reject message in ^TMP($J,
; "GECSSDCT",line#,0)
I CODE="" Q
I $P(CODE,"^")="D " Q
I $E(CODE,1,2)'="D " Q
N X
S X=CODE D ^DIM I '$D(X) Q
I '$D(^GECS(2100.1,DA,0)) Q
L +^GECS(2100.1,DA,25)
S ^GECS(2100.1,DA,25)=CODE
L -^GECS(2100.1,DA,25)
Q
;
;
SETPARAM(DA,PARAM) ; set parameters to be used to rebuild the code sheet
; da = stack internal entry number
; param = parameters used free text from 1-200 characters
I PARAM="" Q
I '$D(^GECS(2100.1,DA,0)) Q
L +^GECS(2100.1,DA,26)
S ^GECS(2100.1,DA,26)=PARAM
L -^GECS(2100.1,DA,26)
Q
;
;
PROCESS(DOCID,ACCORREJ) ; call to process dct for accept or reject msg
; docid = document identifier (entry in 2100.1 stack file)
; accorrej = 'A'ccept or 'R'eject
; pass reject message in ^TMP($J,"GECSSDCT",line#,0)
; start line# with 1 -------------^
N DA,CODE,X
S DOCID=$$PADSPACE^GECSSGET(DOCID)
S DA=+$O(^GECS(2100.1,"B",DOCID,0)) I 'DA Q
I ACCORREJ'="A",ACCORREJ'="R" Q
; set status in stack file
D SETSTAT^GECSSTAA(DA,ACCORREJ)
; for rejects, send mailman message
I ACCORREJ="R",$D(^TMP($J,"GECSSDCT",1,0)) D MAILMSG(DOCID)
; if event code, call it and quit
S CODE=$G(^GECS(2100.1,DA,25))
I CODE'="" S X=CODE D ^DIM I $D(X) S X=$P(CODE,"^",2) X ^%ZOSF("TEST") I $T S CODE=CODE_"(DOCID,ACCORREJ)" X CODE D Q Q
; no event code, and accepted, purge code sheet from stack
I ACCORREJ="A" D KILLCS(DOCID)
Q ; clean up
K ^TMP($J,"GECSSDCT")
Q
;
;
KILLSTAC(DOCID) ; purge stack file entry docid
N DA
S DOCID=$$PADSPACE^GECSSGET(DOCID)
S DA=+$O(^GECS(2100.1,"B",DOCID,0)) I 'DA Q
I '$D(^GECS(2100.1,DA)) Q
D KILLSTAC^GECSPUR1(DA)
Q
;
;
KILLCS(DOCID) ; remove code sheet from stack file entry
N DA
S DOCID=$$PADSPACE^GECSSGET(DOCID)
S DA=+$O(^GECS(2100.1,"B",DOCID,0)) I 'DA Q
K ^GECS(2100.1,DA,10),^GECS(2100.1,DA,11)
Q
;
;
MAILMSG(DOCID) ; send mail message for rejects
; docid = document identifier (file 2100.1 stack file entry)
; ^tmp($j,"gecssdct",line#,0) = reject message
N %,%X,%Y,GECSXMY,SEGMENT,XCNP,XMDISPI,XMDUZ,XMTEXT,XMY,XMZ,ZTSK
S SEGMENT=$E(DOCID,1,2)_":FMS"
I '$O(^GECS(2101.2,"B",SEGMENT,0)) Q
;
; build receiving queue and user array
D RECUSER^GECSSTTR(SEGMENT,1)
I '$D(GECSXMY) Q
S %X="GECSXMY(",%Y="XMY(" D %XY^%RCR
;
S XMDUZ=$S($D(ZTQUEUED):.5,'$G(DUZ):.5,1:DUZ),XMTEXT="^TMP($J,""GECSSDCT"",",XMSUB="GCS TRANSACTION "_SEGMENT_" REJECT IN FMS"
K XMZ D ^XMD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGECSSDCT 2879 printed Sep 23, 2025@19:32:29 Page 2
GECSSDCT ;WISC/RFJ-dct accept,reject message utilities ;25 Apr 94
+1 ;;2.0;GCS;;MAR 14, 1995
+2 QUIT
+3 ;
+4 ;
SETCODE(DA,CODE) ; set event code to be called for accept/reject msg
+1 ; da = stack internal entry number
+2 ; code = D LABEL^ROUTINE
+3 ; when the code gets called, it will pass the 1) document number,
+4 ; 2) 'A'ccepted or 'R'ejected, 3) reject message in ^TMP($J,
+5 ; "GECSSDCT",line#,0)
+6 IF CODE=""
QUIT
+7 IF $PIECE(CODE,"^")="D "
QUIT
+8 IF $EXTRACT(CODE,1,2)'="D "
QUIT
+9 NEW X
+10 SET X=CODE
DO ^DIM
IF '$DATA(X)
QUIT
+11 IF '$DATA(^GECS(2100.1,DA,0))
QUIT
+12 LOCK +^GECS(2100.1,DA,25)
+13 SET ^GECS(2100.1,DA,25)=CODE
+14 LOCK -^GECS(2100.1,DA,25)
+15 QUIT
+16 ;
+17 ;
SETPARAM(DA,PARAM) ; set parameters to be used to rebuild the code sheet
+1 ; da = stack internal entry number
+2 ; param = parameters used free text from 1-200 characters
+3 IF PARAM=""
QUIT
+4 IF '$DATA(^GECS(2100.1,DA,0))
QUIT
+5 LOCK +^GECS(2100.1,DA,26)
+6 SET ^GECS(2100.1,DA,26)=PARAM
+7 LOCK -^GECS(2100.1,DA,26)
+8 QUIT
+9 ;
+10 ;
PROCESS(DOCID,ACCORREJ) ; call to process dct for accept or reject msg
+1 ; docid = document identifier (entry in 2100.1 stack file)
+2 ; accorrej = 'A'ccept or 'R'eject
+3 ; pass reject message in ^TMP($J,"GECSSDCT",line#,0)
+4 ; start line# with 1 -------------^
+5 NEW DA,CODE,X
+6 SET DOCID=$$PADSPACE^GECSSGET(DOCID)
+7 SET DA=+$ORDER(^GECS(2100.1,"B",DOCID,0))
IF 'DA
QUIT
+8 IF ACCORREJ'="A"
IF ACCORREJ'="R"
QUIT
+9 ; set status in stack file
+10 DO SETSTAT^GECSSTAA(DA,ACCORREJ)
+11 ; for rejects, send mailman message
+12 IF ACCORREJ="R"
IF $DATA(^TMP($JOB,"GECSSDCT",1,0))
DO MAILMSG(DOCID)
+13 ; if event code, call it and quit
+14 SET CODE=$GET(^GECS(2100.1,DA,25))
+15 IF CODE'=""
SET X=CODE
DO ^DIM
IF $DATA(X)
SET X=$PIECE(CODE,"^",2)
XECUTE ^%ZOSF("TEST")
IF $TEST
SET CODE=CODE_"(DOCID,ACCORREJ)"
XECUTE CODE
DO Q
QUIT
+16 ; no event code, and accepted, purge code sheet from stack
+17 IF ACCORREJ="A"
DO KILLCS(DOCID)
Q ; clean up
+1 KILL ^TMP($JOB,"GECSSDCT")
+2 QUIT
+3 ;
+4 ;
KILLSTAC(DOCID) ; purge stack file entry docid
+1 NEW DA
+2 SET DOCID=$$PADSPACE^GECSSGET(DOCID)
+3 SET DA=+$ORDER(^GECS(2100.1,"B",DOCID,0))
IF 'DA
QUIT
+4 IF '$DATA(^GECS(2100.1,DA))
QUIT
+5 DO KILLSTAC^GECSPUR1(DA)
+6 QUIT
+7 ;
+8 ;
KILLCS(DOCID) ; remove code sheet from stack file entry
+1 NEW DA
+2 SET DOCID=$$PADSPACE^GECSSGET(DOCID)
+3 SET DA=+$ORDER(^GECS(2100.1,"B",DOCID,0))
IF 'DA
QUIT
+4 KILL ^GECS(2100.1,DA,10),^GECS(2100.1,DA,11)
+5 QUIT
+6 ;
+7 ;
MAILMSG(DOCID) ; send mail message for rejects
+1 ; docid = document identifier (file 2100.1 stack file entry)
+2 ; ^tmp($j,"gecssdct",line#,0) = reject message
+3 NEW %,%X,%Y,GECSXMY,SEGMENT,XCNP,XMDISPI,XMDUZ,XMTEXT,XMY,XMZ,ZTSK
+4 SET SEGMENT=$EXTRACT(DOCID,1,2)_":FMS"
+5 IF '$ORDER(^GECS(2101.2,"B",SEGMENT,0))
QUIT
+6 ;
+7 ; build receiving queue and user array
+8 DO RECUSER^GECSSTTR(SEGMENT,1)
+9 IF '$DATA(GECSXMY)
QUIT
+10 SET %X="GECSXMY("
SET %Y="XMY("
DO %XY^%RCR
+11 ;
+12 SET XMDUZ=$SELECT($DATA(ZTQUEUED):.5,'$GET(DUZ):.5,1:DUZ)
SET XMTEXT="^TMP($J,""GECSSDCT"","
SET XMSUB="GCS TRANSACTION "_SEGMENT_" REJECT IN FMS"
+13 KILL XMZ
DO ^XMD
+14 QUIT
