OCXBDT9 ;SLC/RJS,CLA - BUILD OCX PACKAGE DIAGNOSTIC ROUTINES (Build Runtime Library Routine OCXDI5) ;8/04/98 13:21
;;3.0;ORDER ENTRY/RESULTS REPORTING;**32**;Dec 17,1997
;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
;
EN() ;
;
N R,LINE,TEXT,NOW,RUCI,P1NAME,D0,D1,P2NUM,P2NAM,XCM
S NOW=$$NOW^OCXBDT3,RUCI=$$CUCI^OCXBDT
F LINE=1:1:999 S TEXT=$P($T(TEXT+LINE),";",2,999) Q:TEXT S TEXT=$P(TEXT,";",2,999) S R(LINE,0)=$$CONV^OCXBDT3(TEXT)
;
S D0=0 F S D0=$O(^ORD(101,D0)) Q:'D0 D
.S PNAME=$P($G(^ORD(101,D0,0)),U,1)
.Q:'$L(PNAME)
.S D1=0 F S D1=$O(^ORD(101,D0,10,D1)) Q:'D1 D
..S P2NUM=+^ORD(101,D0,10,D1,0),P2NAME=$P($G(^ORD(101,P2NUM,0)),U,1)
..I ($E(P2NAME,1,15)="OCX ORDER CHECK") D ADD
S R($O(R(""),-1)+1,0)=" ;1;"
S R($O(R(""),-1)+1,0)="$"
;
M ^TMP("OCXBDT",$J,"RTN")=R
S DIE="^TMP(""OCXBDT"","_$J_",""RTN"",",XCN=0,X="OCXDI5"
W !,X X ^%ZOSF("SAVE") W " ... ",XCM," Lines filed" K ^TMP("OCXBDT",$J,"RTN")
;
Q XCM
;
ADD S R($O(R(""),-1)+1,0)=" ;;"_PNAME_U_P2NAME W !!,"Protocol: ",PNAME," -> ",P2NAME Q
;
TEXT ;
;;OCXDI5 ;SLC/RJS,CLA - OCX PACKAGE DIAGNOSTIC UTILITY ROUTINE ;|NOW|
;;|OCXLIN2|
;;|OCXLIN3|
;; ;
;;EN() ;
;; ; Protocol Utilities
;; ;
;; N OCXLINE,OCXTEXT,OCXQUIT
;; S OCXQUIT=0
;; F OCXLINE=1:1:500 S OCXTEXT=$P($T(DATA+OCXLINE),";",2,999) Q:OCXTEXT I $L(OCXTEXT) D Q:OCXQUIT
;; .D DOT^OCXDIAG
;; .S OCXTEXT=$P(OCXTEXT,";",2,999)
;; .S OCXQUIT=$$ADD($P(OCXTEXT,U,1),$P(OCXTEXT,U,2))
;; Q OCXQUIT
;; ;
;;ADD(OCXX,OCXITEM) ;
;; ;
;; N OCXD0,OCXD1,OCXD2,DIE,DIC,DR,X,Y,DA,OCXQUIT
;; S OCXD0=$$DIC("^ORD(101,",OCXX) Q:'OCXD0 0
;; S OCXD1=$$DIC("^ORD(101,",OCXITEM) Q:'OCXD1 0
;; S OCXD2=0 F S OCXD2=$O(^ORD(101,OCXD0,10,OCXD2)) Q:'OCXD2 Q:(+^ORD(101,OCXD0,10,OCXD2,0)=OCXD1)
;; Q:OCXD2 0 S OCXQUIT=0
;; I OCXFLGR W !!," '"_OCXITEM_"' is missing as an Item to the '"_OCXX_"' protocol."
;; Q:'OCXFLGC 0 I OCXFLGA S OCXQUIT=$$READ("Y"," Do you want to add '"_OCXITEM_"' as an Item to '"_OCXX_"' ?","YES") I 'OCXQUIT Q (OCXQUIT[U)
;; S:'$D(^ORD(101,OCXD0,10,0)) ^ORD(101,OCXD0,10,0)="^101.01PA^^"
;; S (DIE,DIC)="^ORD(101,"_OCXD0_",10,"
;; F DA=1:1 Q:'$D(^ORD(101,OCXD0,10,DA,0))
;; S DA(1)=OCXD0
;; S DR=".01///"_OCXITEM
;; S OCXSCR=1 D ^DIE
;; I OCXFLGR W !," added"
;; I 'OCXFLGR W !," '"_OCXITEM_"' added as an Item to the '"_OCXX_"' protocol"
;; ;
;; Q 0
;; ;
;;DIC(DIC,X) S DIC(0)="",OCXSCR=1 D ^DIC Q:(+Y>0) +Y Q 0
;; ;
;;READ(OCXZ0,OCXZA,OCXZB,OCXZL) ;
;; N OCXLINE,DIR,DTOUT,DUOUT,DIRUT,DIROUT
;; Q:'$L($G(OCXZ0)) U
;; S DIR(0)=OCXZ0
;; S:$L($G(OCXZA)) DIR("A")=OCXZA
;; S:$L($G(OCXZB)) DIR("B")=OCXZB
;; F OCXLINE=1:1:($G(OCXZL)-1) W !
;; D ^DIR
;; I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q U
;; Q Y
;; ;
;;DATA ;:
;1;
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HOCXBDT9 2822 printed Dec 13, 2024@02:22:29 Page 2
OCXBDT9 ;SLC/RJS,CLA - BUILD OCX PACKAGE DIAGNOSTIC ROUTINES (Build Runtime Library Routine OCXDI5) ;8/04/98 13:21
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32**;Dec 17,1997
+2 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
+3 ;
EN() ;
+1 ;
+2 NEW R,LINE,TEXT,NOW,RUCI,P1NAME,D0,D1,P2NUM,P2NAM,XCM
+3 SET NOW=$$NOW^OCXBDT3
SET RUCI=$$CUCI^OCXBDT
+4 FOR LINE=1:1:999
SET TEXT=$PIECE($TEXT(TEXT+LINE),";",2,999)
if TEXT
QUIT
SET TEXT=$PIECE(TEXT,";",2,999)
SET R(LINE,0)=$$CONV^OCXBDT3(TEXT)
+5 ;
+6 SET D0=0
FOR
SET D0=$ORDER(^ORD(101,D0))
if 'D0
QUIT
Begin DoDot:1
+7 SET PNAME=$PIECE($GET(^ORD(101,D0,0)),U,1)
+8 if '$LENGTH(PNAME)
QUIT
+9 SET D1=0
FOR
SET D1=$ORDER(^ORD(101,D0,10,D1))
if 'D1
QUIT
Begin DoDot:2
+10 SET P2NUM=+^ORD(101,D0,10,D1,0)
SET P2NAME=$PIECE($GET(^ORD(101,P2NUM,0)),U,1)
+11 IF ($EXTRACT(P2NAME,1,15)="OCX ORDER CHECK")
DO ADD
End DoDot:2
End DoDot:1
+12 SET R($ORDER(R(""),-1)+1,0)=" ;1;"
+13 SET R($ORDER(R(""),-1)+1,0)="$"
+14 ;
+15 MERGE ^TMP("OCXBDT",$JOB,"RTN")=R
+16 SET DIE="^TMP(""OCXBDT"","_$JOB_",""RTN"","
SET XCN=0
SET X="OCXDI5"
+17 WRITE !,X
XECUTE ^%ZOSF("SAVE")
WRITE " ... ",XCM," Lines filed"
KILL ^TMP("OCXBDT",$JOB,"RTN")
+18 ;
+19 QUIT XCM
+20 ;
ADD SET R($ORDER(R(""),-1)+1,0)=" ;;"_PNAME_U_P2NAME
WRITE !!,"Protocol: ",PNAME," -> ",P2NAME
QUIT
+1 ;
TEXT ;
+1 ;;OCXDI5 ;SLC/RJS,CLA - OCX PACKAGE DIAGNOSTIC UTILITY ROUTINE ;|NOW|
+2 ;;|OCXLIN2|
+3 ;;|OCXLIN3|
+4 ;; ;
+5 ;;EN() ;
+6 ;; ; Protocol Utilities
+7 ;; ;
+8 ;; N OCXLINE,OCXTEXT,OCXQUIT
+9 ;; S OCXQUIT=0
+10 ;; F OCXLINE=1:1:500 S OCXTEXT=$P($T(DATA+OCXLINE),";",2,999) Q:OCXTEXT I $L(OCXTEXT) D Q:OCXQUIT
+11 ;; .D DOT^OCXDIAG
+12 ;; .S OCXTEXT=$P(OCXTEXT,";",2,999)
+13 ;; .S OCXQUIT=$$ADD($P(OCXTEXT,U,1),$P(OCXTEXT,U,2))
+14 ;; Q OCXQUIT
+15 ;; ;
+16 ;;ADD(OCXX,OCXITEM) ;
+17 ;; ;
+18 ;; N OCXD0,OCXD1,OCXD2,DIE,DIC,DR,X,Y,DA,OCXQUIT
+19 ;; S OCXD0=$$DIC("^ORD(101,",OCXX) Q:'OCXD0 0
+20 ;; S OCXD1=$$DIC("^ORD(101,",OCXITEM) Q:'OCXD1 0
+21 ;; S OCXD2=0 F S OCXD2=$O(^ORD(101,OCXD0,10,OCXD2)) Q:'OCXD2 Q:(+^ORD(101,OCXD0,10,OCXD2,0)=OCXD1)
+22 ;; Q:OCXD2 0 S OCXQUIT=0
+23 ;; I OCXFLGR W !!," '"_OCXITEM_"' is missing as an Item to the '"_OCXX_"' protocol."
+24 ;; Q:'OCXFLGC 0 I OCXFLGA S OCXQUIT=$$READ("Y"," Do you want to add '"_OCXITEM_"' as an Item to '"_OCXX_"' ?","YES") I 'OCXQUIT Q (OCXQUIT[U)
+25 ;; S:'$D(^ORD(101,OCXD0,10,0)) ^ORD(101,OCXD0,10,0)="^101.01PA^^"
+26 ;; S (DIE,DIC)="^ORD(101,"_OCXD0_",10,"
+27 ;; F DA=1:1 Q:'$D(^ORD(101,OCXD0,10,DA,0))
+28 ;; S DA(1)=OCXD0
+29 ;; S DR=".01///"_OCXITEM
+30 ;; S OCXSCR=1 D ^DIE
+31 ;; I OCXFLGR W !," added"
+32 ;; I 'OCXFLGR W !," '"_OCXITEM_"' added as an Item to the '"_OCXX_"' protocol"
+33 ;; ;
+34 ;; Q 0
+35 ;; ;
+36 ;;DIC(DIC,X) S DIC(0)="",OCXSCR=1 D ^DIC Q:(+Y>0) +Y Q 0
+37 ;; ;
+38 ;;READ(OCXZ0,OCXZA,OCXZB,OCXZL) ;
+39 ;; N OCXLINE,DIR,DTOUT,DUOUT,DIRUT,DIROUT
+40 ;; Q:'$L($G(OCXZ0)) U
+41 ;; S DIR(0)=OCXZ0
+42 ;; S:$L($G(OCXZA)) DIR("A")=OCXZA
+43 ;; S:$L($G(OCXZB)) DIR("B")=OCXZB
+44 ;; F OCXLINE=1:1:($G(OCXZL)-1) W !
+45 ;; D ^DIR
+46 ;; I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q U
+47 ;; Q Y
+48 ;; ;
+49 ;;DATA ;:
+50 ;1;
+51 ;
