GMPLSLI2 ;ISP/TC - Problem Selection List Import Utility ;07/18/17 09:43
;;2.0;Problem List;**49**;Aug 25, 1994;Build 43
;
; External References:
; ICR 10142 EN^DDIOL
;
ISCSV(GMPLLINE) ;Verify that LINE is in CSV format with at least 3 pieces of data
I $L(GMPLLINE)=0 Q 0
N GMPLCSV
S GMPLCSV=$S($L(GMPLLINE,",")>2:1,1:0)
I 'GMPLCSV D
. N GMPLTXT
. S GMPLTXT(1)=""
. S GMPLTXT(2)="The following line is not in CSV format and cannot be processed:"
. S GMPLTXT(3)=" "_GMPLLINE
. D EN^DDIOL(.GMPLTXT)
. H 1
Q GMPLCSV
;============================================
RBLCKHF(GMPLNIN,GMPLNOUT) ;FTG^%ZISH breaks lines at 255 characters. This could
;put a mapping across two lines. Format the ^TMP array so this does not
;happen.
N GMPLCHAR,GMPLI,GMPLJ,GMPLK,GMPLL1,GMPLNL1,GMPLNL2,GMPLTMP
K ^TMP($J,"GMPLNOUT")
S GMPLI="",GMPLNL1=0
F S GMPLI=+$O(^TMP($J,GMPLNIN,GMPLI)) Q:GMPLI=0 D
. S GMPLTMP=^TMP($J,GMPLNIN,GMPLI),GMPLNL1=GMPLNL1+1
. I '$D(^TMP($J,GMPLNIN,GMPLI,"OVF")) S ^TMP($J,GMPLNOUT,GMPLNL1,1)=GMPLTMP Q
. S GMPLL1="",GMPLNL2=0
. F GMPLJ=1:1:$L(GMPLTMP) D
.. S GMPLCHAR=$E(GMPLTMP,GMPLJ)
.. S GMPLL1=GMPLL1_GMPLCHAR
.. I $L(GMPLL1)>230,GMPLCHAR="," S GMPLNL2=GMPLNL2+1,^TMP($J,GMPLNOUT,GMPLNL1,GMPLNL2)=GMPLL1,GMPLL1=""
.;Check for overflow nodes.
. S GMPLJ=0
. F S GMPLJ=+$O(^TMP($J,GMPLNIN,GMPLI,"OVF",GMPLJ)) Q:GMPLJ=0 D
.. S GMPLTMP=^TMP($J,GMPLNIN,GMPLI,"OVF",GMPLJ)
.. F GMPLK=1:1:$L(GMPLTMP) D
... S GMPLCHAR=$E(GMPLTMP,GMPLK)
... S GMPLL1=GMPLL1_GMPLCHAR
... I $L(GMPLL1)>230,GMPLCHAR="," S GMPLNL2=GMPLNL2+1,^TMP($J,GMPLNOUT,GMPLNL1,GMPLNL2)=GMPLL1,GMPLL1=""
. I $L(GMPLL1)>0 S GMPLNL2=GMPLNL2+1,^TMP($J,GMPLNOUT,GMPLNL1,GMPLNL2)=GMPLL1
Q
;============================================
RBLCKWEB(GMPLNIN,GMPLNOUT) ;GETURL^XTHC10 breaks lines at 245 characters. This
;could break a line into two lines. Format the ^TMP array so this does
;not happen.
N GMPLCHAR,GMPLI,GMPLJ,GMPLK,GMPLL1,GMPLLEN,GMPLNL1,GMPLNL2,GMPLTMP
K ^TMP($J,"GMPLNOUT")
S GMPLI="",GMPLNL1=0
F S GMPLI=+$O(^TMP($J,GMPLNIN,GMPLI)) Q:GMPLI=0 D
. S GMPLTMP=^TMP($J,GMPLNIN,GMPLI),GMPLLEN=$L(GMPLTMP)
. I GMPLLEN=0 S GMPLNL1=GMPLNL1+1,^TMP($J,GMPLNOUT,GMPLNL1,1)=GMPLTMP Q
. S GMPLNL1=GMPLNL1+1
. I $D(^TMP($J,GMPLNIN,GMPLI))<11 S ^TMP($J,GMPLNOUT,GMPLNL1,1)=$TR(GMPLTMP,$C(13),"") Q
. S GMPLL1="",GMPLNL2=0
. F GMPLJ=1:1:$L(GMPLTMP) D
.. S GMPLCHAR=$E(GMPLTMP,GMPLJ)
.. I GMPLCHAR=$C(13) Q
.. S GMPLL1=GMPLL1_GMPLCHAR
.. I $L(GMPLL1)>230,GMPLCHAR="," S GMPLNL2=GMPLNL2+1,^TMP($J,GMPLNOUT,GMPLNL1,GMPLNL2)=GMPLL1,GMPLL1=""
.;Check for overflow nodes.
. S GMPLJ=0
. F S GMPLJ=+$O(^TMP($J,GMPLNIN,GMPLI,GMPLJ)) Q:GMPLJ=0 D
.. S GMPLTMP=^TMP($J,GMPLNIN,GMPLI,GMPLJ)
.. F GMPLK=1:1:$L(GMPLTMP) D
... S GMPLCHAR=$E(GMPLTMP,GMPLK)
... I GMPLCHAR=$C(13) Q
... S GMPLL1=GMPLL1_GMPLCHAR
... I $L(GMPLL1)>230,GMPLCHAR="," S GMPLNL2=GMPLNL2+1,^TMP($J,GMPLNOUT,GMPLNL1,GMPLNL2)=GMPLL1,GMPLL1=""
. I $L(GMPLL1)>0 S GMPLNL2=GMPLNL2+1,^TMP($J,GMPLNOUT,GMPLNL1,GMPLNL2)=GMPLL1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMPLSLI2 3088 printed Dec 13, 2024@02:30:26 Page 2
GMPLSLI2 ;ISP/TC - Problem Selection List Import Utility ;07/18/17 09:43
+1 ;;2.0;Problem List;**49**;Aug 25, 1994;Build 43
+2 ;
+3 ; External References:
+4 ; ICR 10142 EN^DDIOL
+5 ;
ISCSV(GMPLLINE) ;Verify that LINE is in CSV format with at least 3 pieces of data
+1 IF $LENGTH(GMPLLINE)=0
QUIT 0
+2 NEW GMPLCSV
+3 SET GMPLCSV=$SELECT($LENGTH(GMPLLINE,",")>2:1,1:0)
+4 IF 'GMPLCSV
Begin DoDot:1
+5 NEW GMPLTXT
+6 SET GMPLTXT(1)=""
+7 SET GMPLTXT(2)="The following line is not in CSV format and cannot be processed:"
+8 SET GMPLTXT(3)=" "_GMPLLINE
+9 DO EN^DDIOL(.GMPLTXT)
+10 HANG 1
End DoDot:1
+11 QUIT GMPLCSV
+12 ;============================================
RBLCKHF(GMPLNIN,GMPLNOUT) ;FTG^%ZISH breaks lines at 255 characters. This could
+1 ;put a mapping across two lines. Format the ^TMP array so this does not
+2 ;happen.
+3 NEW GMPLCHAR,GMPLI,GMPLJ,GMPLK,GMPLL1,GMPLNL1,GMPLNL2,GMPLTMP
+4 KILL ^TMP($JOB,"GMPLNOUT")
+5 SET GMPLI=""
SET GMPLNL1=0
+6 FOR
SET GMPLI=+$ORDER(^TMP($JOB,GMPLNIN,GMPLI))
if GMPLI=0
QUIT
Begin DoDot:1
+7 SET GMPLTMP=^TMP($JOB,GMPLNIN,GMPLI)
SET GMPLNL1=GMPLNL1+1
+8 IF '$DATA(^TMP($JOB,GMPLNIN,GMPLI,"OVF"))
SET ^TMP($JOB,GMPLNOUT,GMPLNL1,1)=GMPLTMP
QUIT
+9 SET GMPLL1=""
SET GMPLNL2=0
+10 FOR GMPLJ=1:1:$LENGTH(GMPLTMP)
Begin DoDot:2
+11 SET GMPLCHAR=$EXTRACT(GMPLTMP,GMPLJ)
+12 SET GMPLL1=GMPLL1_GMPLCHAR
+13 IF $LENGTH(GMPLL1)>230
IF GMPLCHAR=","
SET GMPLNL2=GMPLNL2+1
SET ^TMP($JOB,GMPLNOUT,GMPLNL1,GMPLNL2)=GMPLL1
SET GMPLL1=""
End DoDot:2
+14 ;Check for overflow nodes.
+15 SET GMPLJ=0
+16 FOR
SET GMPLJ=+$ORDER(^TMP($JOB,GMPLNIN,GMPLI,"OVF",GMPLJ))
if GMPLJ=0
QUIT
Begin DoDot:2
+17 SET GMPLTMP=^TMP($JOB,GMPLNIN,GMPLI,"OVF",GMPLJ)
+18 FOR GMPLK=1:1:$LENGTH(GMPLTMP)
Begin DoDot:3
+19 SET GMPLCHAR=$EXTRACT(GMPLTMP,GMPLK)
+20 SET GMPLL1=GMPLL1_GMPLCHAR
+21 IF $LENGTH(GMPLL1)>230
IF GMPLCHAR=","
SET GMPLNL2=GMPLNL2+1
SET ^TMP($JOB,GMPLNOUT,GMPLNL1,GMPLNL2)=GMPLL1
SET GMPLL1=""
End DoDot:3
End DoDot:2
+22 IF $LENGTH(GMPLL1)>0
SET GMPLNL2=GMPLNL2+1
SET ^TMP($JOB,GMPLNOUT,GMPLNL1,GMPLNL2)=GMPLL1
End DoDot:1
+23 QUIT
+24 ;============================================
RBLCKWEB(GMPLNIN,GMPLNOUT) ;GETURL^XTHC10 breaks lines at 245 characters. This
+1 ;could break a line into two lines. Format the ^TMP array so this does
+2 ;not happen.
+3 NEW GMPLCHAR,GMPLI,GMPLJ,GMPLK,GMPLL1,GMPLLEN,GMPLNL1,GMPLNL2,GMPLTMP
+4 KILL ^TMP($JOB,"GMPLNOUT")
+5 SET GMPLI=""
SET GMPLNL1=0
+6 FOR
SET GMPLI=+$ORDER(^TMP($JOB,GMPLNIN,GMPLI))
if GMPLI=0
QUIT
Begin DoDot:1
+7 SET GMPLTMP=^TMP($JOB,GMPLNIN,GMPLI)
SET GMPLLEN=$LENGTH(GMPLTMP)
+8 IF GMPLLEN=0
SET GMPLNL1=GMPLNL1+1
SET ^TMP($JOB,GMPLNOUT,GMPLNL1,1)=GMPLTMP
QUIT
+9 SET GMPLNL1=GMPLNL1+1
+10 IF $DATA(^TMP($JOB,GMPLNIN,GMPLI))<11
SET ^TMP($JOB,GMPLNOUT,GMPLNL1,1)=$TRANSLATE(GMPLTMP,$CHAR(13),"")
QUIT
+11 SET GMPLL1=""
SET GMPLNL2=0
+12 FOR GMPLJ=1:1:$LENGTH(GMPLTMP)
Begin DoDot:2
+13 SET GMPLCHAR=$EXTRACT(GMPLTMP,GMPLJ)
+14 IF GMPLCHAR=$CHAR(13)
QUIT
+15 SET GMPLL1=GMPLL1_GMPLCHAR
+16 IF $LENGTH(GMPLL1)>230
IF GMPLCHAR=","
SET GMPLNL2=GMPLNL2+1
SET ^TMP($JOB,GMPLNOUT,GMPLNL1,GMPLNL2)=GMPLL1
SET GMPLL1=""
End DoDot:2
+17 ;Check for overflow nodes.
+18 SET GMPLJ=0
+19 FOR
SET GMPLJ=+$ORDER(^TMP($JOB,GMPLNIN,GMPLI,GMPLJ))
if GMPLJ=0
QUIT
Begin DoDot:2
+20 SET GMPLTMP=^TMP($JOB,GMPLNIN,GMPLI,GMPLJ)
+21 FOR GMPLK=1:1:$LENGTH(GMPLTMP)
Begin DoDot:3
+22 SET GMPLCHAR=$EXTRACT(GMPLTMP,GMPLK)
+23 IF GMPLCHAR=$CHAR(13)
QUIT
+24 SET GMPLL1=GMPLL1_GMPLCHAR
+25 IF $LENGTH(GMPLL1)>230
IF GMPLCHAR=","
SET GMPLNL2=GMPLNL2+1
SET ^TMP($JOB,GMPLNOUT,GMPLNL1,GMPLNL2)=GMPLL1
SET GMPLL1=""
End DoDot:3
End DoDot:2
+26 IF $LENGTH(GMPLL1)>0
SET GMPLNL2=GMPLNL2+1
SET ^TMP($JOB,GMPLNOUT,GMPLNL1,GMPLNL2)=GMPLL1
End DoDot:1
+27 QUIT
