OCXODSP3.m

OCXODSP3 ;SLC/RJS,CLA -  Rule Display (Display a Data Field) ;10/29/98  12:37

 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32**;Dec 17,1997

 ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998

 ;

EN(OCXD0,OCXTAB,OCXRM,OCXCON) ;

 ;

 N OCXD1,OCXD,OCXRD,OCXE,OCXSUB

 ;

 S OCXCON=$G(OCXCON),OCXTAB=+$G(OCXTAB) S:'$G(OCXD0) OCXD0=+$$DIC("^OCXS(860.4,","AEMQ") Q:'OCXD0

 ;

 S OCXRD="" D DIQ("^OCXS(860.4,",OCXD0,.OCXRD)

 F OCXSUB="LINK" S OCXD1=0 F  S OCXD1=$O(^OCXS(860.4,OCXD0,OCXSUB,OCXD1)) Q:'OCXD1  D

 .S OCXD(0)=OCXD0,OCXD=OCXD1 D DIQ("^OCXS(860.4,"_OCXD0_","""_OCXSUB_""",",.OCXD,.OCXRD)

 ;

 W !

 W ! D FIELD("Data Field Name:",$G(OCXRD(860.4,OCXD0,.01,"E")),OCXTAB,OCXRM)

 W ! D FIELD("   Abbreviation:",$G(OCXRD(860.4,OCXD0,1,"E")),OCXTAB,OCXRM)

 ;

 I $L(OCXCON),'$D(OCXRD(860.41,OCXCON)) S OCXCON=$O(^OCXS(860.6,"B","DATABASE LOOKUP",0)) I OCXCON,'$D(OCXRD(860.41,OCXCON)) S OCXCON=0

 ;

 I 'OCXCON W ! D FIELD("   Data Context:","  ** ERROR ** Data Context not found for this data field.",OCXTAB,OCXRM) Q

 ;

 W ! D FIELD("   Data Context:",$P($G(^OCXS(860.6,OCXCON,0)),U,1),OCXTAB,OCXRM)

 ;

 D EN^OCXODSP4($G(OCXRD(860.41,OCXCON,1,"E")),OCXTAB+OCXOFF,OCXRM)

 ;

 Q

 ;

PARNUM(OCXOPER) ;

 ;

 N OCXPF,OCXPFN

 S OCXPF=$O(^OCXS(863.9,+OCXOPER,"PAR","B","OCXO GENERATE CODE FUNCTION",0)) Q:'OCXPF 0

 S OCXPF=$G(^OCXS(863.9,+OCXOPER,"PAR",+OCXPF,"VAL"))

 Q:'$L(OCXPF) 0

 I OCXPF S OCXPFN=OCXPF

 E  S OCXPFN=0 F  S OCXPFN=$O(^OCXS(863.7,"B",$E(OCXPF,1,30),OCXPFN)) Q:'OCXPFN  Q:($P($G(^OCXS(863.7,+OCXPFN,0)),U,1)=OCXPF)

 Q:'OCXPFN 0 Q +$O(^OCXS(863.7,+OCXPFN,"PAR",999),-1)

 ;

FIELD(TITLE,STRING,TAB,MARGIN) ;

 ;

 W ?TAB,TITLE

 ;

 N PTR,SUBSTR,STRLEN

 ;

 S STRLEN=MARGIN-($L(TITLE)+TAB)-5

 S SUBSTR="" F PTR=1:1:$L(STRING," ") D

 .I ($L(SUBSTR)>STRLEN) W ?(TAB+$L(TITLE)+1),SUBSTR W:$L($P(STRING," ",PTR+1)) ! S SUBSTR=""

 .S:$L(SUBSTR) SUBSTR=SUBSTR_" " S SUBSTR=SUBSTR_$P(STRING," ",PTR)

 W:$L(SUBSTR) ?(TAB+$L(TITLE)+1),SUBSTR

 Q

 ;

DIC(OCXDIC,OCXDIC0,OCXDICA,OCXX,OCXDICS,OCXDR) ;

 ;

 N DIC,X,Y

 S DIC=$G(OCXDIC) Q:'$L(DIC) -1

 S DIC(0)=$G(OCXDIC0) S:$L($G(OCXX)) X=OCXX

 S:$L($G(OCXDICS)) DIC("S")=OCXDICS

 S:$L($G(OCXDICA)) DIC("A")=OCXDICA

 S:$L($G(OCXDR)) DIC("DR")=OCXDR

 D ^DIC Q:(Y<1) 0 Q Y

 ;

 ;

DIQ(DIC,DA,OCXARY) ;

 ;

 N DR,DIQ S DR=".01:99999",DIQ="OCXARY(",DIQ(0)="IEN" D EN^DIQ1

 Q

 ;

MULT(OCXD0,OCXTAB,OCXRM) ;

 ;

 N OCXCON

 S OCXCON=0 F  S OCXCON=$O(^OCXS(860.4,OCXD0,"LINK",OCXCON)) Q:'OCXCON  D EN(OCXD0,OCXTAB,OCXRM,OCXCON)

 Q

 ;

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---OCXODSP3   2522     printed  Feb 18, 2025@23:51:47                                                                                                                                                                                                    Page 2

OCXODSP3  ;SLC/RJS,CLA -  Rule Display (Display a Data Field) ;10/29/98  12:37

 +1       ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32**;Dec 17,1997

 +2       ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998

 +3       ;

EN(OCXD0,OCXTAB,OCXRM,OCXCON) ;

 +1       ;

 +2        NEW OCXD1,OCXD,OCXRD,OCXE,OCXSUB

 +3       ;

 +4        SET OCXCON=$GET(OCXCON)

           SET OCXTAB=+$GET(OCXTAB)

           if '$GET(OCXD0)

               SET OCXD0=+$$DIC("^OCXS(860.4,","AEMQ")

           if 'OCXD0

               QUIT 

 +5       ;

 +6        SET OCXRD=""

           DO DIQ("^OCXS(860.4,",OCXD0,.OCXRD)

 +7        FOR OCXSUB="LINK"

               SET OCXD1=0

               FOR 

                   SET OCXD1=$ORDER(^OCXS(860.4,OCXD0,OCXSUB,OCXD1))

                   if 'OCXD1

                       QUIT 

                   Begin DoDot:1

 +8                    SET OCXD(0)=OCXD0

                       SET OCXD=OCXD1

                       DO DIQ("^OCXS(860.4,"_OCXD0_","""_OCXSUB_""",",.OCXD,.OCXRD)

                   End DoDot:1

 +9       ;

 +10       WRITE !

 +11       WRITE !

           DO FIELD("Data Field Name:",$GET(OCXRD(860.4,OCXD0,.01,"E")),OCXTAB,OCXRM)

 +12       WRITE !

           DO FIELD("   Abbreviation:",$GET(OCXRD(860.4,OCXD0,1,"E")),OCXTAB,OCXRM)

 +13      ;

 +14       IF $LENGTH(OCXCON)

               IF '$DATA(OCXRD(860.41,OCXCON))

                   SET OCXCON=$ORDER(^OCXS(860.6,"B","DATABASE LOOKUP",0))

                   IF OCXCON

                       IF '$DATA(OCXRD(860.41,OCXCON))

                           SET OCXCON=0

 +15      ;

 +16       IF 'OCXCON

               WRITE !

               DO FIELD("   Data Context:","  ** ERROR ** Data Context not found for this data field.",OCXTAB,OCXRM)

               QUIT 

 +17      ;

 +18       WRITE !

           DO FIELD("   Data Context:",$PIECE($GET(^OCXS(860.6,OCXCON,0)),U,1),OCXTAB,OCXRM)

 +19      ;

 +20       DO EN^OCXODSP4($GET(OCXRD(860.41,OCXCON,1,"E")),OCXTAB+OCXOFF,OCXRM)

 +21      ;

 +22       QUIT 

 +23      ;

PARNUM(OCXOPER) ;

 +1       ;

 +2        NEW OCXPF,OCXPFN

 +3        SET OCXPF=$ORDER(^OCXS(863.9,+OCXOPER,"PAR","B","OCXO GENERATE CODE FUNCTION",0))

           if 'OCXPF

               QUIT 0

 +4        SET OCXPF=$GET(^OCXS(863.9,+OCXOPER,"PAR",+OCXPF,"VAL"))

 +5        if '$LENGTH(OCXPF)

               QUIT 0

 +6        IF OCXPF

               SET OCXPFN=OCXPF

 +7       IF '$TEST

               SET OCXPFN=0

               FOR 

                   SET OCXPFN=$ORDER(^OCXS(863.7,"B",$EXTRACT(OCXPF,1,30),OCXPFN))

                   if 'OCXPFN

                       QUIT 

                   if ($PIECE($GET(^OCXS(863.7,+OCXPFN,0)),U,1)=OCXPF)

                       QUIT 

 +8        if 'OCXPFN

               QUIT 0

           QUIT +$ORDER(^OCXS(863.7,+OCXPFN,"PAR",999),-1)

 +9       ;

FIELD(TITLE,STRING,TAB,MARGIN) ;

 +1       ;

 +2        WRITE ?TAB,TITLE

 +3       ;

 +4        NEW PTR,SUBSTR,STRLEN

 +5       ;

 +6        SET STRLEN=MARGIN-($LENGTH(TITLE)+TAB)-5

 +7        SET SUBSTR=""

           FOR PTR=1:1:$LENGTH(STRING," ")

               Begin DoDot:1

 +8                IF ($LENGTH(SUBSTR)>STRLEN)

                       WRITE ?(TAB+$LENGTH(TITLE)+1),SUBSTR

                       if $LENGTH($PIECE(STRING," ",PTR+1))

                           WRITE !

                       SET SUBSTR=""

 +9                if $LENGTH(SUBSTR)

                       SET SUBSTR=SUBSTR_" "

                   SET SUBSTR=SUBSTR_$PIECE(STRING," ",PTR)

               End DoDot:1

 +10       if $LENGTH(SUBSTR)

               WRITE ?(TAB+$LENGTH(TITLE)+1),SUBSTR

 +11       QUIT 

 +12      ;

DIC(OCXDIC,OCXDIC0,OCXDICA,OCXX,OCXDICS,OCXDR) ;

 +1       ;

 +2        NEW DIC,X,Y

 +3        SET DIC=$GET(OCXDIC)

           if '$LENGTH(DIC)

               QUIT -1

 +4        SET DIC(0)=$GET(OCXDIC0)

           if $LENGTH($GET(OCXX))

               SET X=OCXX

 +5        if $LENGTH($GET(OCXDICS))

               SET DIC("S")=OCXDICS

 +6        if $LENGTH($GET(OCXDICA))

               SET DIC("A")=OCXDICA

 +7        if $LENGTH($GET(OCXDR))

               SET DIC("DR")=OCXDR

 +8        DO ^DIC

           if (Y<1)

               QUIT 0

           QUIT Y

 +9       ;

 +10      ;

DIQ(DIC,DA,OCXARY) ;

 +1       ;

 +2        NEW DR,DIQ

           SET DR=".01:99999"

           SET DIQ="OCXARY("

           SET DIQ(0)="IEN"

           DO EN^DIQ1

 +3        QUIT 

 +4       ;

MULT(OCXD0,OCXTAB,OCXRM) ;

 +1       ;

 +2        NEW OCXCON

 +3        SET OCXCON=0

           FOR 

               SET OCXCON=$ORDER(^OCXS(860.4,OCXD0,"LINK",OCXCON))

               if 'OCXCON

                   QUIT 

               DO EN(OCXD0,OCXTAB,OCXRM,OCXCON)

 +4        QUIT 

 +5       ;