OCXOEDT6 ;SLC/RJS,CLA - Edit Site's Local Terms ;5/27/99 16:52
;;3.0;ORDER ENTRY/RESULTS REPORTING;**32**;Dec 17,1997
;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
;
S ;
;
N OCXERR,OCXR,DIE,DIC,DR,X,Y,OCXD0,OCXREC,IOP,IOF,OCXEDIT
;
I '$D(IOF) S IOP="HOME" D ^%ZIS K IOP
;
S (OCXEDIT,OCXERR)=0 F W @IOF,!! D LIST Q:$$EDIT($$LOOKUP)
D:OCXEDIT QUE
;
Q
;
LOOKUP() N DIC,X,Y S DIC("A")="Select National Term: ",DIC="^OCXS(860.9,",DIC(0)="AEQM" D ^DIC Q:(Y<0) 0 Q +Y
;
QUE ;
D QUE^OCXOCMPV(30)
W !!,"Expert system compiler queued to run in 30 seconds."
W !,"You will be sent a Mailman bulletin when it has finished.",!!
H 3
Q
;
LIST ;
N OCXD0,OCXCNT
W !,?10,"Order Check National Terms",!
S (OCXCNT,OCXD0)=0 F S OCXD0=$O(^OCXS(860.9,OCXD0)) Q:'OCXD0 D Q:(OCXCNT>9)
.S OCXNAME=$P($G(^OCXS(860.9,OCXD0,0)),U,1) Q:'$L(OCXNAME)
.S OCXCNT=OCXCNT+1
.W !,?5,OCXNAME
I OCXD0 W !!,?5," < Enter ?? to see the rest of the national terms on this list>"
W !
Q
;
EDIT(OCXD0) ;
;
Q:'OCXD0 1
;
N OCXF,OCXFN,OCXD1,OCXD2,DA,OCXCNT,OCXX,OCXQUIT,OCXSCR
;
F D Q:OCXQUIT
.;
.S OCXQUIT=0 D CONV(OCXD0)
.;
.S OCXF=+$P(^OCXS(860.9,OCXD0,0),U,2)
.S OCXSCR=$G(^OCXS(860.9,OCXD0,2))
.W @IOF,!!,"National Term: ",$P(^OCXS(860.9,OCXD0,0),U,1)
.I 'OCXF W !!," Database Error: Pointed to file not specified." S OCXD1=$$PAUSE,OCXQUIT=1 Q
.S OCXFN=$$FILE^OCXBDTD(OCXF,"NAME")
.I '$L(OCXFN) W !!," Database Error: Pointed to file (",OCXF,") does not exist." S OCXD1=$$PAUSE,OCXQUIT=1 Q
.;
.W !!," Translated from file: '",OCXFN,"' ",+OCXF
.;
.W !
.S OCXCNT=0,OCXD1="" F S OCXD1=$O(^OCXS(860.9,OCXD0,1,"B",OCXD1)) Q:'$L(OCXD1) D Q:OCXQUIT
..S OCXD2="" F S OCXD2=$O(^OCXS(860.9,OCXD0,1,"B",OCXD1,OCXD2)) Q:'OCXD2 D Q:OCXQUIT
...W !,?5,$P(^OCXS(860.9,OCXD0,1,OCXD2,0),U,1)," (",OCXD2,")"
...S OCXCNT=OCXCNT+1 I '(OCXCNT#10) S OCXQUIT=($$PAUSE*10)
.;
.Q:OCXQUIT
.;
.W ! S OCXD1=$$DIC(OCXF,$G(OCXSCR)) S OCXQUIT=(OCXD1<1) Q:OCXQUIT
.;
.I $D(^OCXS(860.9,OCXD0,1,+OCXD1,0)) D Q
..I $$READ("Y","Do you want remove '"_$P(^OCXS(860.9,OCXD0,1,+OCXD1,0),U,1)_" ("_(+OCXD1)_")' from the list ","NO") K ^OCXS(860.9,OCXD0,1,+OCXD1) W " removed..." S OCXEDIT=1 H 2 Q
..W " not removed..." H 2 Q
.;
.S ^OCXS(860.9,OCXD0,1,0)="^860.91IA^^"
.S ^OCXS(860.9,OCXD0,1,+OCXD1,0)=$P(OCXD1,U,2)_U_(+OCXD1)
.S OCXEDIT=1
;
Q (OCXQUIT>1)
;
DIC(OCXDIC,OCXDICS) ;
;
;
N X,Y,DIC,OCXDEL
S DIC=+OCXDIC Q:'$G(DIC) 0
S DIC(0)="AMNEQ",DIC("W")="W ""("",Y,"")"""
S:$L($G(OCXDICS)) DIC("S")=$G(OCXDICS)
D ^DIC
Q:(+Y<1) 0 Q Y
;
CONV(OCXD0) ;
;
N OCXREC1,OCXREC2,OCXF,OCXF0
K OCXREC1,OCXREC2
M OCXREC1=^OCXS(860.9,OCXD0)
;
S OCXF=+$P(OCXREC1(0),U,2) Q:'OCXF
;
K OCXREC1(1,"B"),OCXREC1(1,"C")
S OCXD1=0 F S OCXD1=$O(OCXREC1(1,OCXD1)) Q:'OCXD1 D
.N OCXNAME,OCXPTR
.S OCXPTR=+$P($G(OCXREC1(1,OCXD1,0)),U,2)
.I 'OCXPTR K OCXREC1(1,OCXD1) Q
.S OCXNAME=$$PTR(OCXF,+OCXPTR)
.K OCXREC1(1,OCXD1)
.Q:'$L(OCXNAME)
.S OCXREC1(1,OCXD1,0)=OCXNAME_U_OCXPTR
.S OCXREC1(1,"C",OCXPTR,OCXD1)=""
;
S OCXREC2(0)=OCXREC1(0)
S:$L($G(OCXREC1(2))) OCXREC2(2)=OCXREC1(2)
I $D(OCXREC1(1,0)) D
.N OCXD1,OCXD2,OCXD3,OCXX
.S OCXREC2(1,0)=$P(OCXREC1(1,0),U,1,2)
.S OCXD1=0 F S OCXD1=$O(OCXREC1(1,"C",OCXD1)) Q:'OCXD1 D
..S OCXD2=0 F S OCXD2=$O(OCXREC1(1,"C",OCXD1,OCXD2)) Q:'OCXD2 D
...Q:'$D(OCXREC1(1,OCXD2,0))
...N OCXT,OCXP
...S OCXT=$P(OCXREC1(1,OCXD2,0),U,1)
...S OCXP=$P(OCXREC1(1,OCXD2,0),U,2)
...S OCXREC2(1,OCXP,0)=OCXT_U_OCXP
...S OCXREC2(1,"B",OCXT,OCXP)=""
...S OCXREC2(1,"C",OCXP,OCXP)=""
...S OCXREC2(1,0)="^860.91IA^"_OCXP_U_($P($G(OCXREC2(1,0)),U,4)+1)
;
K ^OCXS(860.9,OCXD0) M ^OCXS(860.9,OCXD0)=OCXREC2
;
Q
;
PTR(FILE,D0) ;
;
Q:'FILE ""
Q:'D0 ""
N REF,NAME
S REF=$$FILE^OCXBDTD(+FILE,"GLOBAL NAME") Q:'$L(REF) ""
X "S NAME=$P($G("_REF_D0_",0)),U,1)"
Q NAME
;
PAUSE() N X W !!," Press <enter> to continue... " R X:DTIME W ! Q ((X[U)*10)
;
READ(OCX0,OCXA,OCXB,OCXL) ;
N X,DIR,DTOUT,DUOUT,DIRUT,DIROUT
Q:'$L($G(OCX0)) U
S DIR(0)=OCX0
S:$L($G(OCXA)) DIR("A")=OCXA
S:$L($G(OCXB)) DIR("B")=OCXB
F X=1:1:($G(OCXL)-1) W !
D ^DIR
I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q U
Q Y
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HOCXOEDT6 4305 printed Oct 16, 2024@18:26:10 Page 2
OCXOEDT6 ;SLC/RJS,CLA - Edit Site's Local Terms ;5/27/99 16:52
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32**;Dec 17,1997
+2 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
+3 ;
S ;
+1 ;
+2 NEW OCXERR,OCXR,DIE,DIC,DR,X,Y,OCXD0,OCXREC,IOP,IOF,OCXEDIT
+3 ;
+4 IF '$DATA(IOF)
SET IOP="HOME"
DO ^%ZIS
KILL IOP
+5 ;
+6 SET (OCXEDIT,OCXERR)=0
FOR
WRITE @IOF,!!
DO LIST
if $$EDIT($$LOOKUP)
QUIT
+7 if OCXEDIT
DO QUE
+8 ;
+9 QUIT
+10 ;
LOOKUP() NEW DIC,X,Y
SET DIC("A")="Select National Term: "
SET DIC="^OCXS(860.9,"
SET DIC(0)="AEQM"
DO ^DIC
if (Y<0)
QUIT 0
QUIT +Y
+1 ;
QUE ;
+1 DO QUE^OCXOCMPV(30)
+2 WRITE !!,"Expert system compiler queued to run in 30 seconds."
+3 WRITE !,"You will be sent a Mailman bulletin when it has finished.",!!
+4 HANG 3
+5 QUIT
+6 ;
LIST ;
+1 NEW OCXD0,OCXCNT
+2 WRITE !,?10,"Order Check National Terms",!
+3 SET (OCXCNT,OCXD0)=0
FOR
SET OCXD0=$ORDER(^OCXS(860.9,OCXD0))
if 'OCXD0
QUIT
Begin DoDot:1
+4 SET OCXNAME=$PIECE($GET(^OCXS(860.9,OCXD0,0)),U,1)
if '$LENGTH(OCXNAME)
QUIT
+5 SET OCXCNT=OCXCNT+1
+6 WRITE !,?5,OCXNAME
End DoDot:1
if (OCXCNT>9)
QUIT
+7 IF OCXD0
WRITE !!,?5," < Enter ?? to see the rest of the national terms on this list>"
+8 WRITE !
+9 QUIT
+10 ;
EDIT(OCXD0) ;
+1 ;
+2 if 'OCXD0
QUIT 1
+3 ;
+4 NEW OCXF,OCXFN,OCXD1,OCXD2,DA,OCXCNT,OCXX,OCXQUIT,OCXSCR
+5 ;
+6 FOR
Begin DoDot:1
+7 ;
+8 SET OCXQUIT=0
DO CONV(OCXD0)
+9 ;
+10 SET OCXF=+$PIECE(^OCXS(860.9,OCXD0,0),U,2)
+11 SET OCXSCR=$GET(^OCXS(860.9,OCXD0,2))
+12 WRITE @IOF,!!,"National Term: ",$PIECE(^OCXS(860.9,OCXD0,0),U,1)
+13 IF 'OCXF
WRITE !!," Database Error: Pointed to file not specified."
SET OCXD1=$$PAUSE
SET OCXQUIT=1
QUIT
+14 SET OCXFN=$$FILE^OCXBDTD(OCXF,"NAME")
+15 IF '$LENGTH(OCXFN)
WRITE !!," Database Error: Pointed to file (",OCXF,") does not exist."
SET OCXD1=$$PAUSE
SET OCXQUIT=1
QUIT
+16 ;
+17 WRITE !!," Translated from file: '",OCXFN,"' ",+OCXF
+18 ;
+19 WRITE !
+20 SET OCXCNT=0
SET OCXD1=""
FOR
SET OCXD1=$ORDER(^OCXS(860.9,OCXD0,1,"B",OCXD1))
if '$LENGTH(OCXD1)
QUIT
Begin DoDot:2
+21 SET OCXD2=""
FOR
SET OCXD2=$ORDER(^OCXS(860.9,OCXD0,1,"B",OCXD1,OCXD2))
if 'OCXD2
QUIT
Begin DoDot:3
+22 WRITE !,?5,$PIECE(^OCXS(860.9,OCXD0,1,OCXD2,0),U,1)," (",OCXD2,")"
+23 SET OCXCNT=OCXCNT+1
IF '(OCXCNT#10)
SET OCXQUIT=($$PAUSE*10)
End DoDot:3
if OCXQUIT
QUIT
End DoDot:2
if OCXQUIT
QUIT
+24 ;
+25 if OCXQUIT
QUIT
+26 ;
+27 WRITE !
SET OCXD1=$$DIC(OCXF,$GET(OCXSCR))
SET OCXQUIT=(OCXD1<1)
if OCXQUIT
QUIT
+28 ;
+29 IF $DATA(^OCXS(860.9,OCXD0,1,+OCXD1,0))
Begin DoDot:2
+30 IF $$READ("Y","Do you want remove '"_$PIECE(^OCXS(860.9,OCXD0,1,+OCXD1,0),U,1)_" ("_(+OCXD1)_")' from the list ","NO")
KILL ^OCXS(860.9,OCXD0,1,+OCXD1)
WRITE " removed..."
SET OCXEDIT=1
HANG 2
QUIT
+31 WRITE " not removed..."
HANG 2
QUIT
End DoDot:2
QUIT
+32 ;
+33 SET ^OCXS(860.9,OCXD0,1,0)="^860.91IA^^"
+34 SET ^OCXS(860.9,OCXD0,1,+OCXD1,0)=$PIECE(OCXD1,U,2)_U_(+OCXD1)
+35 SET OCXEDIT=1
End DoDot:1
if OCXQUIT
QUIT
+36 ;
+37 QUIT (OCXQUIT>1)
+38 ;
DIC(OCXDIC,OCXDICS) ;
+1 ;
+2 ;
+3 NEW X,Y,DIC,OCXDEL
+4 SET DIC=+OCXDIC
if '$GET(DIC)
QUIT 0
+5 SET DIC(0)="AMNEQ"
SET DIC("W")="W ""("",Y,"")"""
+6 if $LENGTH($GET(OCXDICS))
SET DIC("S")=$GET(OCXDICS)
+7 DO ^DIC
+8 if (+Y<1)
QUIT 0
QUIT Y
+9 ;
CONV(OCXD0) ;
+1 ;
+2 NEW OCXREC1,OCXREC2,OCXF,OCXF0
+3 KILL OCXREC1,OCXREC2
+4 MERGE OCXREC1=^OCXS(860.9,OCXD0)
+5 ;
+6 SET OCXF=+$PIECE(OCXREC1(0),U,2)
if 'OCXF
QUIT
+7 ;
+8 KILL OCXREC1(1,"B"),OCXREC1(1,"C")
+9 SET OCXD1=0
FOR
SET OCXD1=$ORDER(OCXREC1(1,OCXD1))
if 'OCXD1
QUIT
Begin DoDot:1
+10 NEW OCXNAME,OCXPTR
+11 SET OCXPTR=+$PIECE($GET(OCXREC1(1,OCXD1,0)),U,2)
+12 IF 'OCXPTR
KILL OCXREC1(1,OCXD1)
QUIT
+13 SET OCXNAME=$$PTR(OCXF,+OCXPTR)
+14 KILL OCXREC1(1,OCXD1)
+15 if '$LENGTH(OCXNAME)
QUIT
+16 SET OCXREC1(1,OCXD1,0)=OCXNAME_U_OCXPTR
+17 SET OCXREC1(1,"C",OCXPTR,OCXD1)=""
End DoDot:1
+18 ;
+19 SET OCXREC2(0)=OCXREC1(0)
+20 if $LENGTH($GET(OCXREC1(2)))
SET OCXREC2(2)=OCXREC1(2)
+21 IF $DATA(OCXREC1(1,0))
Begin DoDot:1
+22 NEW OCXD1,OCXD2,OCXD3,OCXX
+23 SET OCXREC2(1,0)=$PIECE(OCXREC1(1,0),U,1,2)
+24 SET OCXD1=0
FOR
SET OCXD1=$ORDER(OCXREC1(1,"C",OCXD1))
if 'OCXD1
QUIT
Begin DoDot:2
+25 SET OCXD2=0
FOR
SET OCXD2=$ORDER(OCXREC1(1,"C",OCXD1,OCXD2))
if 'OCXD2
QUIT
Begin DoDot:3
+26 if '$DATA(OCXREC1(1,OCXD2,0))
QUIT
+27 NEW OCXT,OCXP
+28 SET OCXT=$PIECE(OCXREC1(1,OCXD2,0),U,1)
+29 SET OCXP=$PIECE(OCXREC1(1,OCXD2,0),U,2)
+30 SET OCXREC2(1,OCXP,0)=OCXT_U_OCXP
+31 SET OCXREC2(1,"B",OCXT,OCXP)=""
+32 SET OCXREC2(1,"C",OCXP,OCXP)=""
+33 SET OCXREC2(1,0)="^860.91IA^"_OCXP_U_($PIECE($GET(OCXREC2(1,0)),U,4)+1)
End DoDot:3
End DoDot:2
End DoDot:1
+34 ;
+35 KILL ^OCXS(860.9,OCXD0)
MERGE ^OCXS(860.9,OCXD0)=OCXREC2
+36 ;
+37 QUIT
+38 ;
PTR(FILE,D0) ;
+1 ;
+2 if 'FILE
QUIT ""
+3 if 'D0
QUIT ""
+4 NEW REF,NAME
+5 SET REF=$$FILE^OCXBDTD(+FILE,"GLOBAL NAME")
if '$LENGTH(REF)
QUIT ""
+6 XECUTE "S NAME=$P($G("_REF_D0_",0)),U,1)"
+7 QUIT NAME
+8 ;
PAUSE() NEW X
WRITE !!," Press <enter> to continue... "
READ X:DTIME
WRITE !
QUIT ((X[U)*10)
+1 ;
READ(OCX0,OCXA,OCXB,OCXL) ;
+1 NEW X,DIR,DTOUT,DUOUT,DIRUT,DIROUT
+2 if '$LENGTH($GET(OCX0))
QUIT U
+3 SET DIR(0)=OCX0
+4 if $LENGTH($GET(OCXA))
SET DIR("A")=OCXA
+5 if $LENGTH($GET(OCXB))
SET DIR("B")=OCXB
+6 FOR X=1:1:($GET(OCXL)-1)
WRITE !
+7 DO ^DIR
+8 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)!$DATA(DIROUT)
QUIT U
+9 QUIT Y
+10 ;
