OCXBDT9.m

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 ---OCXBDT9   2822     printed  Feb 18, 2025@23:48:56                                                                                                                                                                                                     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      ;