SCMCHLR ;BP/DJB - PCMM HL7 Re-transmit Rejects ; 8/25/99 2:29pm
;;5.3;Scheduling;**177**;May 01, 1999
;
EN ;
NEW DFN,SCDELETE,SCMSG,VARPTR
TOP ;
D GETMSG ;............Get SCMSG() array for Austin Mailman message.
G:'SCMSG("IEN") EXIT ;Quit if no message selected.
D ARRAY ;.............Build array of message text
D PARSE G:'DFN EXIT ;.Get DFN, VARPTR, and SCDELETE
G:'$$ASK() TOP ;......Are they sure they want to re-transmit?
D RETRAN ;............Re-transmit selected items.
EXIT ;
KILL ^TMP("REJECTS",$J)
Q
;
GETMSG ;Prompt for reject message number.
;Output:
; SCMSG("IEN") - Message IEN
; Return SCMSG("IEN")=0 if no msg selected.
; SCMSG("SUBJ") - Message subject
; SCMSG("FROM") - Message sender
;
NEW %,%DT,ANS,DATA,HD,LINE,X,Y
;
S $P(LINE,"-",IOM)=""
S HD="RE-TRANSMIT PCMM HL7 MESSAGES"
W @IOF,!?(IOM-$L(HD)\2),HD
W !,LINE
W !!,"Select an Austin HL7 rejection Mailman message."
GETMSG1 KILL SCMSG
S SCMSG("IEN")=0
W !!,"Enter MESSAGE NUMBER: "
R ANS:300 S:'$T ANS="^" I "^"[ANS Q
I ANS=" " D G:'ANS GETMSG1
. S ANS=$G(^DISV(DUZ,"PCMM REJECTS"))
. W ANS
S DATA=$$NET^XMRENT(ANS)
I DATA="" D G GETMSG1
. W !,"Enter a valid Mailman message number or <RET> to Quit."
;
;Check if this is a valid reject message.
S SCMSG("FROM")=$P(DATA,"^",3)
I SCMSG("FROM")'="Austin" D GETMSG2 G GETMSG1
S SCMSG("SUBJ")=$P(DATA,"^",6)
I SCMSG("SUBJ")'?.E D GETMSG2 G GETMSG1
S SCMSG("IEN")=ANS
;
;Support for <SPACE BAR><RET> convention
S ^DISV(DUZ,"PCMM REJECTS")=ANS
Q
GETMSG2 ;
W !,"Sorry, not a valid PCMM HL7 reject message number."
Q
;
ARRAY ;Build array of message text.
NEW CNT,X,XMER,XMPOS,XMRG,XMZ
;
KILL ^TMP("REJECTS",$J)
S CNT=1
S XMZ=SCMSG("IEN")
F S X=$$READ^XMGAPI1() Q:XMER=-1 D ;
. S ^TMP("REJECTS",$J,CNT)=X
. S CNT=CNT+1
Q
;
PARSE ;Parse out DFN and VARPTR from text of message
;Return: DFN - Patient IEN
; VARPTR - Variable pointer
;
NEW ID,IDLONG,LN,PTPI
;
S LN=$G(^TMP("REJECTS",$J,1))
S DFN=+LN ;................................Patient IEN
I 'DFN D Q
. W !,"Cannot identify patient. Aborting."
S LN=$G(^TMP("REJECTS",$J,2))
S ID=$P(LN," ",1) ;........................Get ID
S ID=$P(ID,"-",2) ;........................Strip off facility number
I 'ID D Q
. S DFN=0
. W !,"Cannot identify event ID. Aborting."
S IDLONG=$P($G(^SCPT(404.49,ID,0)),U,1) ;..Get long form of ID
S PTPI=$P(IDLONG,"-",1) ;..................File 404.43 IEN
I 'PTPI D Q
. S DFN=0
. W !,"Cannot identify long ID. Aborting."
I '$D(^SCPT(404.43,PTPI)) S SCDELETE=1 ;...Flag to process a delete
S VARPTR=PTPI_";SCPT(404.43," ;............Create event pointer
Q
;
ASK() ;Ask if they want to re-tranmit selected msgs.
NEW %,%Y
W !!,"Patient: ",$P($G(^DPT(DFN,0)),U,1)
ASK1 W !!,"Are you sure you want to re-transmit"
S %=1 D YN^DICN
I %=0 W " Enter YES or NO" G ASK1
I %'=1 Q 0
Q 1
;
RETRAN ;Re-transmit selected items.
;
NEW PT,PTPI,RESULT,SCFAC,XMITARRY
NEW HL,HLECH,HLEID,HLFS,HLQ
;
;Initialize array
S XMITARRY="^TMP(""PCMM"",""HL7"","_$J_")" ;..Segments
KILL @XMITARRY
;
;Get faciltiy number
S SCFAC=+$P($$SITE^VASITE(),"^",3)
;
;Get pointer to sending event
S HLEID=$$HLEID^SCMCHL()
I 'HLEID D Q
. W "Unable to initialize HL7 variables - protocol not found"
;
;Initialize HL7 variables
D INIT^HLFNC2(HLEID,.HL)
I $O(HL(""))="" W $P(HL,"^",2) Q
;
;Build segment array
I $G(SCDELETE) D I 1 ;....................Process a deletion
. S PTPI=$P(VARPTR,";",1)
. D PTPD^SCMCHLB2(PTPI)
E D I +RESULT<0 W $P(RESULT,"^",2) Q ;..Process a normal entry
. S RESULT=$$BUILD^SCMCHLB(VARPTR,.HL,.XMITARRY)
;
;Generate message
;S RESULT=$$GENERATE^SCMCHLG()
;
KILL @XMITARRY
W !!,"Message re-transmitted...",!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCMCHLR 3881 printed Sep 23, 2025@20:16:53 Page 2
SCMCHLR ;BP/DJB - PCMM HL7 Re-transmit Rejects ; 8/25/99 2:29pm
+1 ;;5.3;Scheduling;**177**;May 01, 1999
+2 ;
EN ;
+1 NEW DFN,SCDELETE,SCMSG,VARPTR
TOP ;
+1 ;............Get SCMSG() array for Austin Mailman message.
DO GETMSG
+2 ;Quit if no message selected.
if 'SCMSG("IEN")
GOTO EXIT
+3 ;.............Build array of message text
DO ARRAY
+4 ;.Get DFN, VARPTR, and SCDELETE
DO PARSE
if 'DFN
GOTO EXIT
+5 ;......Are they sure they want to re-transmit?
if '$$ASK()
GOTO TOP
+6 ;............Re-transmit selected items.
DO RETRAN
EXIT ;
+1 KILL ^TMP("REJECTS",$JOB)
+2 QUIT
+3 ;
GETMSG ;Prompt for reject message number.
+1 ;Output:
+2 ; SCMSG("IEN") - Message IEN
+3 ; Return SCMSG("IEN")=0 if no msg selected.
+4 ; SCMSG("SUBJ") - Message subject
+5 ; SCMSG("FROM") - Message sender
+6 ;
+7 NEW %,%DT,ANS,DATA,HD,LINE,X,Y
+8 ;
+9 SET $PIECE(LINE,"-",IOM)=""
+10 SET HD="RE-TRANSMIT PCMM HL7 MESSAGES"
+11 WRITE @IOF,!?(IOM-$LENGTH(HD)\2),HD
+12 WRITE !,LINE
+13 WRITE !!,"Select an Austin HL7 rejection Mailman message."
GETMSG1 KILL SCMSG
+1 SET SCMSG("IEN")=0
+2 WRITE !!,"Enter MESSAGE NUMBER: "
+3 READ ANS:300
if '$TEST
SET ANS="^"
IF "^"[ANS
QUIT
+4 IF ANS=" "
Begin DoDot:1
+5 SET ANS=$GET(^DISV(DUZ,"PCMM REJECTS"))
+6 WRITE ANS
End DoDot:1
if 'ANS
GOTO GETMSG1
+7 SET DATA=$$NET^XMRENT(ANS)
+8 IF DATA=""
Begin DoDot:1
+9 WRITE !,"Enter a valid Mailman message number or <RET> to Quit."
End DoDot:1
GOTO GETMSG1
+10 ;
+11 ;Check if this is a valid reject message.
+12 SET SCMSG("FROM")=$PIECE(DATA,"^",3)
+13 IF SCMSG("FROM")'="Austin"
DO GETMSG2
GOTO GETMSG1
+14 SET SCMSG("SUBJ")=$PIECE(DATA,"^",6)
+15 IF SCMSG("SUBJ")'?.E
DO GETMSG2
GOTO GETMSG1
+16 SET SCMSG("IEN")=ANS
+17 ;
+18 ;Support for <SPACE BAR><RET> convention
+19 SET ^DISV(DUZ,"PCMM REJECTS")=ANS
+20 QUIT
GETMSG2 ;
+1 WRITE !,"Sorry, not a valid PCMM HL7 reject message number."
+2 QUIT
+3 ;
ARRAY ;Build array of message text.
+1 NEW CNT,X,XMER,XMPOS,XMRG,XMZ
+2 ;
+3 KILL ^TMP("REJECTS",$JOB)
+4 SET CNT=1
+5 SET XMZ=SCMSG("IEN")
+6 ;
FOR
SET X=$$READ^XMGAPI1()
if XMER=-1
QUIT
Begin DoDot:1
+7 SET ^TMP("REJECTS",$JOB,CNT)=X
+8 SET CNT=CNT+1
End DoDot:1
+9 QUIT
+10 ;
PARSE ;Parse out DFN and VARPTR from text of message
+1 ;Return: DFN - Patient IEN
+2 ; VARPTR - Variable pointer
+3 ;
+4 NEW ID,IDLONG,LN,PTPI
+5 ;
+6 SET LN=$GET(^TMP("REJECTS",$JOB,1))
+7 ;................................Patient IEN
SET DFN=+LN
+8 IF 'DFN
Begin DoDot:1
+9 WRITE !,"Cannot identify patient. Aborting."
End DoDot:1
QUIT
+10 SET LN=$GET(^TMP("REJECTS",$JOB,2))
+11 ;........................Get ID
SET ID=$PIECE(LN," ",1)
+12 ;........................Strip off facility number
SET ID=$PIECE(ID,"-",2)
+13 IF 'ID
Begin DoDot:1
+14 SET DFN=0
+15 WRITE !,"Cannot identify event ID. Aborting."
End DoDot:1
QUIT
+16 ;..Get long form of ID
SET IDLONG=$PIECE($GET(^SCPT(404.49,ID,0)),U,1)
+17 ;..................File 404.43 IEN
SET PTPI=$PIECE(IDLONG,"-",1)
+18 IF 'PTPI
Begin DoDot:1
+19 SET DFN=0
+20 WRITE !,"Cannot identify long ID. Aborting."
End DoDot:1
QUIT
+21 ;...Flag to process a delete
IF '$DATA(^SCPT(404.43,PTPI))
SET SCDELETE=1
+22 ;............Create event pointer
SET VARPTR=PTPI_";SCPT(404.43,"
+23 QUIT
+24 ;
ASK() ;Ask if they want to re-tranmit selected msgs.
+1 NEW %,%Y
+2 WRITE !!,"Patient: ",$PIECE($GET(^DPT(DFN,0)),U,1)
ASK1 WRITE !!,"Are you sure you want to re-transmit"
+1 SET %=1
DO YN^DICN
+2 IF %=0
WRITE " Enter YES or NO"
GOTO ASK1
+3 IF %'=1
QUIT 0
+4 QUIT 1
+5 ;
RETRAN ;Re-transmit selected items.
+1 ;
+2 NEW PT,PTPI,RESULT,SCFAC,XMITARRY
+3 NEW HL,HLECH,HLEID,HLFS,HLQ
+4 ;
+5 ;Initialize array
+6 ;..Segments
SET XMITARRY="^TMP(""PCMM"",""HL7"","_$JOB_")"
+7 KILL @XMITARRY
+8 ;
+9 ;Get faciltiy number
+10 SET SCFAC=+$PIECE($$SITE^VASITE(),"^",3)
+11 ;
+12 ;Get pointer to sending event
+13 SET HLEID=$$HLEID^SCMCHL()
+14 IF 'HLEID
Begin DoDot:1
+15 WRITE "Unable to initialize HL7 variables - protocol not found"
End DoDot:1
QUIT
+16 ;
+17 ;Initialize HL7 variables
+18 DO INIT^HLFNC2(HLEID,.HL)
+19 IF $ORDER(HL(""))=""
WRITE $PIECE(HL,"^",2)
QUIT
+20 ;
+21 ;Build segment array
+22 ;....................Process a deletion
IF $GET(SCDELETE)
Begin DoDot:1
+23 SET PTPI=$PIECE(VARPTR,";",1)
+24 DO PTPD^SCMCHLB2(PTPI)
End DoDot:1
IF 1
+25 ;..Process a normal entry
IF '$TEST
Begin DoDot:1
+26 SET RESULT=$$BUILD^SCMCHLB(VARPTR,.HL,.XMITARRY)
End DoDot:1
IF +RESULT<0
WRITE $PIECE(RESULT,"^",2)
QUIT
+27 ;
+28 ;Generate message
+29 ;S RESULT=$$GENERATE^SCMCHLG()
+30 ;
+31 KILL @XMITARRY
+32 WRITE !!,"Message re-transmitted...",!
+33 QUIT
