HDISDSR1 ;BPFO/DTG - HDI MAILMAN SERVER COLLECT SDO DATA; Apr 07, 2018@12:42
;;1.0;HEALTH DATA & INFORMATICS;**22**;Feb 22, 2005;Build 26
;
;
INIT ; initialize vars and file
;
; Uses ICR 5812 to read file 4.3 field 8.3
;
K @HDISV
S HDITXT=0,HDICRLF=$C(13,10),HDITAB=$C(9),HDIJB=$J,U="^"
S HDISTR=""
S HDISITE=$$SITE^VASITE,HDISTN=$P(HDISITE,"^",2),HDIST=$P(HDISITE,"^",3)
I HDIST="" S HDIST="???"
;
S HDISUB=$$UP^XLFSTR(XQSUB)
;get max lines and make character count
N A,B S A=$$GET1^DIQ(4.3,"1,",8.3,"I") S B=$S((+A=0):5469,(A>15000):15000,1:A)
S HDIMAX=((B*250)-((B*250)*.3))\1
;
Q
;
MAILSEND(HDISUBJ) ; Send extract back to requestor.
;
N HDINSTR,HDITASK,HDITO,XMERR,XMZ,A
;
;ZEXCEPT: XQSND
;
;S 1=1
S HDITO(XQSND)=""
S HDINSTR("ADDR FLAGS")="R"
S HDINSTR("FROM")="HDI_SDO_CODES"
S HDISUBJ=$E(HDISUBJ,1,65)
D SENDMSG^XMXAPI(.5,HDISUBJ,"^TMP($J,""HDIDATA"")",.HDITO,.HDINSTR,.HDITASK)
S A=$G(^DTGHD("A",0)),A=A+1,^DTGHD("A",0)=A,^DTGHD("A",A)=HDITASK
Q
;
ENCODE(HDISTR) ; Encode a string, keep remainder for next line
; Call with ORSTR by reference, Remainder returned in LRSTR
;
S HDIQUIT=0,HDILEN=$L(HDISTR)
F D Q:HDIQUIT
. I $L(HDISTR)<45 S HDIQUIT=1 Q
. S HDIX=$E(HDISTR,1,45),LT=LT+$L(HDIX)
. S HDINODE=HDINODE+1,@HDISV@(HDINODE)=$$UUEN(HDIX)
. S HDISTR=$E(HDISTR,46,HDILEN)
Q
;
UUEN(STR) ; Uuencode string passed in.
N J,K,LEN,HDII,HDIX,S,TMP,X,Y
S TMP="",LEN=$L(STR)
F HDII=1:3:LEN D
. S HDIX=$E(STR,HDII,HDII+2)
. I $L(HDIX)<3 S HDIX=HDIX_$E(" ",1,3-$L(HDIX))
. S S=$A(HDIX,1)*256+$A(HDIX,2)*256+$A(HDIX,3),Y=""
. F K=0:1:23 S Y=(S\(2**K)#2)_Y
. F K=1:6:24 D
. . S J=$$DEC^XLFUTL($E(Y,K,K+5),2)
. . S TMP=TMP_$C(J+32)
S TMP=$C(LEN+32)_TMP
Q TMP
;
UUBEGFN(HDFILENM) ; Construct uuencode "begin" coding
; Call with HDFILENM = name of uuencoded file attachment
;
; Returns HDIX = string with "begin..."_file name
;
N HDIX
S HDIX="begin 644 "_HDFILENM
Q HDIX
;
;
SETDATA ; Set data into report structure
S HDINODE=$O(^TMP($J,"HDIDATA",""),-1)
I HDITXT S HDINODE=HDINODE+1,@HDISV@(HDINODE)=HDISTR,HDISTR="" Q
I 'HDITXT D ENCODE(.HDISTR)
Q
;
CLEAN ; clean up
D CLEAN^HDISDSR
D ^%ZISC
Q
;
DISER ; display return error type
I RERROR=0 Q
N MSG,A,I,B,J,RR
; remove multi's of repeating error #'s
F I=1:1 S A=$P(RERROR,",",I) Q:A="" S B(A)=""
;
S J=$O(@HDISV@(""),-1),J=J+1
S @HDISV@(J)=$$UUBEGFN(HDIFER)
S HDISTR="ERROR ITEMS FROM HDI SDO LOOKUP"_HDICRLF
D SETDATA
S A=0 F S A=$O(B(A)) Q:'A S HDISTR=HDISTR_A_") "_$P($T(DISTXT+A),";",3)_HDICRLF D SETDATA
I $O(RERRARY(0))>0 D ;<
. S HDISTR=HDISTR_HDICRLF_"Error Array Display"_HDICRLF D SETDATA
. S A=0 F S A=$O(RERRARY(A)) Q:'A S HDISTR=HDISTR_RERRARY(A)_HDICRLF D SETDATA
I HDISTR'="" S HDINODE=HDINODE+1,@HDISV@(HDINODE)=$$UUEN(HDISTR)
S @HDISV@(HDINODE+1)=" "
S @HDISV@(HDINODE+2)="end"
Q
;
DISTXT ; error text
;;Area Not Sent.
;;Lookup Value Not Sent.
;;Return Value Not Sent.
;;Improper Search Area
;;Single Item Not Found in ORDERABLE ITEMS File 101.43.
;;Single Item Not in Area.
;;Partial Lookup Error.
;;Orderable Items File Does Not Have Lab Pointer for Item.
;;Orderable Item Lab Pointer Not Found in Lab File.
;;
;;
;;Type of Lookup not Sent
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHDISDSR1 3334 printed Nov 22, 2024@17:06:43 Page 2
HDISDSR1 ;BPFO/DTG - HDI MAILMAN SERVER COLLECT SDO DATA; Apr 07, 2018@12:42
+1 ;;1.0;HEALTH DATA & INFORMATICS;**22**;Feb 22, 2005;Build 26
+2 ;
+3 ;
INIT ; initialize vars and file
+1 ;
+2 ; Uses ICR 5812 to read file 4.3 field 8.3
+3 ;
+4 KILL @HDISV
+5 SET HDITXT=0
SET HDICRLF=$CHAR(13,10)
SET HDITAB=$CHAR(9)
SET HDIJB=$JOB
SET U="^"
+6 SET HDISTR=""
+7 SET HDISITE=$$SITE^VASITE
SET HDISTN=$PIECE(HDISITE,"^",2)
SET HDIST=$PIECE(HDISITE,"^",3)
+8 IF HDIST=""
SET HDIST="???"
+9 ;
+10 SET HDISUB=$$UP^XLFSTR(XQSUB)
+11 ;get max lines and make character count
+12 NEW A,B
SET A=$$GET1^DIQ(4.3,"1,",8.3,"I")
SET B=$SELECT((+A=0):5469,(A>15000):15000,1:A)
+13 SET HDIMAX=((B*250)-((B*250)*.3))\1
+14 ;
+15 QUIT
+16 ;
MAILSEND(HDISUBJ) ; Send extract back to requestor.
+1 ;
+2 NEW HDINSTR,HDITASK,HDITO,XMERR,XMZ,A
+3 ;
+4 ;ZEXCEPT: XQSND
+5 ;
+6 ;S 1=1
+7 SET HDITO(XQSND)=""
+8 SET HDINSTR("ADDR FLAGS")="R"
+9 SET HDINSTR("FROM")="HDI_SDO_CODES"
+10 SET HDISUBJ=$EXTRACT(HDISUBJ,1,65)
+11 DO SENDMSG^XMXAPI(.5,HDISUBJ,"^TMP($J,""HDIDATA"")",.HDITO,.HDINSTR,.HDITASK)
+12 SET A=$GET(^DTGHD("A",0))
SET A=A+1
SET ^DTGHD("A",0)=A
SET ^DTGHD("A",A)=HDITASK
+13 QUIT
+14 ;
ENCODE(HDISTR) ; Encode a string, keep remainder for next line
+1 ; Call with ORSTR by reference, Remainder returned in LRSTR
+2 ;
+3 SET HDIQUIT=0
SET HDILEN=$LENGTH(HDISTR)
+4 FOR
Begin DoDot:1
+5 IF $LENGTH(HDISTR)<45
SET HDIQUIT=1
QUIT
+6 SET HDIX=$EXTRACT(HDISTR,1,45)
SET LT=LT+$LENGTH(HDIX)
+7 SET HDINODE=HDINODE+1
SET @HDISV@(HDINODE)=$$UUEN(HDIX)
+8 SET HDISTR=$EXTRACT(HDISTR,46,HDILEN)
End DoDot:1
if HDIQUIT
QUIT
+9 QUIT
+10 ;
UUEN(STR) ; Uuencode string passed in.
+1 NEW J,K,LEN,HDII,HDIX,S,TMP,X,Y
+2 SET TMP=""
SET LEN=$LENGTH(STR)
+3 FOR HDII=1:3:LEN
Begin DoDot:1
+4 SET HDIX=$EXTRACT(STR,HDII,HDII+2)
+5 IF $LENGTH(HDIX)<3
SET HDIX=HDIX_$EXTRACT(" ",1,3-$LENGTH(HDIX))
+6 SET S=$ASCII(HDIX,1)*256+$ASCII(HDIX,2)*256+$ASCII(HDIX,3)
SET Y=""
+7 FOR K=0:1:23
SET Y=(S\(2**K)#2)_Y
+8 FOR K=1:6:24
Begin DoDot:2
+9 SET J=$$DEC^XLFUTL($EXTRACT(Y,K,K+5),2)
+10 SET TMP=TMP_$CHAR(J+32)
End DoDot:2
End DoDot:1
+11 SET TMP=$CHAR(LEN+32)_TMP
+12 QUIT TMP
+13 ;
UUBEGFN(HDFILENM) ; Construct uuencode "begin" coding
+1 ; Call with HDFILENM = name of uuencoded file attachment
+2 ;
+3 ; Returns HDIX = string with "begin..."_file name
+4 ;
+5 NEW HDIX
+6 SET HDIX="begin 644 "_HDFILENM
+7 QUIT HDIX
+8 ;
+9 ;
SETDATA ; Set data into report structure
+1 SET HDINODE=$ORDER(^TMP($JOB,"HDIDATA",""),-1)
+2 IF HDITXT
SET HDINODE=HDINODE+1
SET @HDISV@(HDINODE)=HDISTR
SET HDISTR=""
QUIT
+3 IF 'HDITXT
DO ENCODE(.HDISTR)
+4 QUIT
+5 ;
CLEAN ; clean up
+1 DO CLEAN^HDISDSR
+2 DO ^%ZISC
+3 QUIT
+4 ;
DISER ; display return error type
+1 IF RERROR=0
QUIT
+2 NEW MSG,A,I,B,J,RR
+3 ; remove multi's of repeating error #'s
+4 FOR I=1:1
SET A=$PIECE(RERROR,",",I)
if A=""
QUIT
SET B(A)=""
+5 ;
+6 SET J=$ORDER(@HDISV@(""),-1)
SET J=J+1
+7 SET @HDISV@(J)=$$UUBEGFN(HDIFER)
+8 SET HDISTR="ERROR ITEMS FROM HDI SDO LOOKUP"_HDICRLF
+9 DO SETDATA
+10 SET A=0
FOR
SET A=$ORDER(B(A))
if 'A
QUIT
SET HDISTR=HDISTR_A_") "_$PIECE($TEXT(DISTXT+A),";",3)_HDICRLF
DO SETDATA
+11 ;<
IF $ORDER(RERRARY(0))>0
Begin DoDot:1
+12 SET HDISTR=HDISTR_HDICRLF_"Error Array Display"_HDICRLF
DO SETDATA
+13 SET A=0
FOR
SET A=$ORDER(RERRARY(A))
if 'A
QUIT
SET HDISTR=HDISTR_RERRARY(A)_HDICRLF
DO SETDATA
End DoDot:1
+14 IF HDISTR'=""
SET HDINODE=HDINODE+1
SET @HDISV@(HDINODE)=$$UUEN(HDISTR)
+15 SET @HDISV@(HDINODE+1)=" "
+16 SET @HDISV@(HDINODE+2)="end"
+17 QUIT
+18 ;
DISTXT ; error text
+1 ;;Area Not Sent.
+2 ;;Lookup Value Not Sent.
+3 ;;Return Value Not Sent.
+4 ;;Improper Search Area
+5 ;;Single Item Not Found in ORDERABLE ITEMS File 101.43.
+6 ;;Single Item Not in Area.
+7 ;;Partial Lookup Error.
+8 ;;Orderable Items File Does Not Have Lab Pointer for Item.
+9 ;;Orderable Item Lab Pointer Not Found in Lab File.
+10 ;;
+11 ;;
+12 ;;Type of Lookup not Sent
