- 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 Jan 18, 2025@02:57:37 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