Routine: ORY57

ORY57 ;SLC/MKB - Postinit for patch OR*3*57 ;6/2/99  15:35

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

POST ; -- task job for EN

 N ZTRTN,ZTDTH,ZTIO,ZTDESC,ZTSK,MSG

 S ZTRTN="EN^ORY57",ZTDTH=$H,ZTIO="",ZTDESC="Remove bad B xref nodes"

 D ^%ZTLOAD S MSG="Task "_$S($G(ZTSK):"#"_ZTSK,1:"not")_" started."

 D MES^XPDUTL(MSG)

EN ; -- fix xrefs corrupted by Convert Protocols option

 N ORIDX,ORDITEM,ORDMENU,ORDA,ORITM,ORPOS

 S ORIDX="^ORD(101.41,""AD"")"

 F  S ORIDX=$Q(@ORIDX) Q:ORIDX'?1"^ORD(101.41,""AD"",".E  D

 . S ORDITEM=+$P(ORIDX,",",3),ORDMENU=+$P(ORIDX,",",4),ORDA=+$P(ORIDX,",",5)

 . S ORITM=$G(^ORD(101.41,ORDITEM,10,ORDA,0)) Q:$P(ORITM,U,2)'=ORDITEM  ;ok

 . K ^ORD(101.41,ORDITEM,10,ORDA) D CKDLG ;ck ORDITEM for bad data

 . D XREF S ORPOS=+$P(ORITM,U)

 . I $D(^ORD(101.41,ORDMENU,10,ORDA,0))!$O(^ORD(101.41,ORDMENU,10,"B",ORPOS,0)) K @ORIDX Q

 . S ^ORD(101.41,ORDMENU,10,ORDA,0)=$$XUTL

XREF ; -- rebuild Item B&D xrefs for ORDMENU

 N LAST,TOTAL,NODE,DA S (LAST,TOTAL)=0

 K ^ORD(101.41,ORDMENU,10,"B"),^ORD(101.41,ORDMENU,10,"D") S DA=0

 F  S DA=$O(^ORD(101.41,ORDMENU,10,DA)) Q:DA'>0  S NODE=$G(^(DA,0)) D

 . S:NODE ^ORD(101.41,ORDMENU,10,"B",+$P(NODE,U),DA)=""

 . S:$P(NODE,U,2) ^ORD(101.41,ORDMENU,10,"D",+$P(NODE,U,2),DA)=""

 . S LAST=DA,TOTAL=TOTAL+1

 S $P(^ORD(101.41,ORDMENU,10,0),U,3,4)=LAST_U_TOTAL

XUTL() ; -- find ORDMENU item in ^XUTL, return data

 N ORPITEM,ORPMENU,ORNM,XUTL,OLDPOS,ORY

 S ORNM=$P($G(^ORD(101.41,ORDMENU,0)),U),ORPMENU=$$FIND1^DIC(101,,"O",ORNM)

 S ORNM=$P($G(^ORD(101.41,ORDITEM,0)),U),ORPITEM=$$FIND1^DIC(101,,"O",ORNM)

 S ORY=$P(ORITM,U,1,2) G:(ORPMENU'>0)!(ORPITEM'>0) XQ

 S OLDPOS=$$FINDXUTL^ORCMEDT1(ORPMENU,ORPITEM) G:OLDPOS'>0 XQ

 S XUTL=$G(^XUTL("XQORM",ORPMENU_";ORD(101,",OLDPOS,0))

 S:$P(XUTL,U,2)=ORPITEM ORY=ORY_U_$P(XUTL,U,4)_U_$S($P(XUTL,U,3)'=$P($G(^ORD(101.41,ORDITEM,0)),U,2):$P(XUTL,U,3),1:"")

XQ Q ORY

CKDLG ; -- ck ORDITEM for bad data

 Q:'$D(^ORD(101.41,ORDITEM,10))  N ORIDX,OROOT,ORP,ORI

 S ORIDX="^ORD(101.41,"_ORDITEM_",10,""A"")",OROOT="^ORD(101.41,"_ORDITEM_",10,"""

 F  S ORIDX=$Q(@ORIDX) Q:$E(ORIDX,1,$L(OROOT))'=OROOT  D

 . S ORP=$L(ORIDX,","),ORI=+$P(ORIDX,",",ORP) ;last piece=DA

 . I ORI=ORDA K @ORIDX

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORY57   2273     printed  Feb 19, 2025@00:09:32                                                                                                                                                                                                       Page 2

ORY57     ;SLC/MKB - Postinit for patch OR*3*57 ;6/2/99  15:35

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

 +2       ;

POST      ; -- task job for EN

 +1       ;

 +2        NEW ZTRTN,ZTDTH,ZTIO,ZTDESC,ZTSK,MSG

 +3        SET ZTRTN="EN^ORY57"

           SET ZTDTH=$HOROLOG

           SET ZTIO=""

           SET ZTDESC="Remove bad B xref nodes"

 +4        DO ^%ZTLOAD

           SET MSG="Task "_$SELECT($GET(ZTSK):"#"_ZTSK,1:"not")_" started."

 +5        DO MES^XPDUTL(MSG)

 +6        QUIT

 +7       ;

EN        ; -- fix xrefs corrupted by Convert Protocols option

 +1       ;

 +2        NEW ORIDX,ORDITEM,ORDMENU,ORDA,ORITM,ORPOS

 +3        SET ORIDX="^ORD(101.41,""AD"")"

 +4        FOR

               SET ORIDX=$QUERY(@ORIDX)

               if ORIDX'?1"^ORD(101.41,""AD"",".E

                   QUIT

               Begin DoDot:1

 +5                SET ORDITEM=+$PIECE(ORIDX,",",3)

                   SET ORDMENU=+$PIECE(ORIDX,",",4)

                   SET ORDA=+$PIECE(ORIDX,",",5)

 +6       ;ok

                   SET ORITM=$GET(^ORD(101.41,ORDITEM,10,ORDA,0))

                   if $PIECE(ORITM,U,2)'=ORDITEM

                       QUIT

 +7       ;ck ORDITEM for bad data

                   KILL ^ORD(101.41,ORDITEM,10,ORDA)

                   DO CKDLG

 +8                DO XREF

                   SET ORPOS=+$PIECE(ORITM,U)

 +9                IF $DATA(^ORD(101.41,ORDMENU,10,ORDA,0))!$ORDER(^ORD(101.41,ORDMENU,10,"B",ORPOS,0))

                       KILL @ORIDX

                       QUIT

 +10               SET ^ORD(101.41,ORDMENU,10,ORDA,0)=$$XUTL

               End DoDot:1

 +11       QUIT

 +12      ;

XREF      ; -- rebuild Item B&D xrefs for ORDMENU

 +1        NEW LAST,TOTAL,NODE,DA

           SET (LAST,TOTAL)=0

 +2        KILL ^ORD(101.41,ORDMENU,10,"B"),^ORD(101.41,ORDMENU,10,"D")

           SET DA=0

 +3        FOR

               SET DA=$ORDER(^ORD(101.41,ORDMENU,10,DA))

               if DA'>0

                   QUIT

               SET NODE=$GET(^(DA,0))

               Begin DoDot:1

 +4                if NODE

                       SET ^ORD(101.41,ORDMENU,10,"B",+$PIECE(NODE,U),DA)=""

 +5                if $PIECE(NODE,U,2)

                       SET ^ORD(101.41,ORDMENU,10,"D",+$PIECE(NODE,U,2),DA)=""

 +6                SET LAST=DA

                   SET TOTAL=TOTAL+1

               End DoDot:1

 +7        SET $PIECE(^ORD(101.41,ORDMENU,10,0),U,3,4)=LAST_U_TOTAL

 +8        QUIT

 +9       ;

XUTL()    ; -- find ORDMENU item in ^XUTL, return data

 +1        NEW ORPITEM,ORPMENU,ORNM,XUTL,OLDPOS,ORY

 +2        SET ORNM=$PIECE($GET(^ORD(101.41,ORDMENU,0)),U)

           SET ORPMENU=$$FIND1^DIC(101,,"O",ORNM)

 +3        SET ORNM=$PIECE($GET(^ORD(101.41,ORDITEM,0)),U)

           SET ORPITEM=$$FIND1^DIC(101,,"O",ORNM)

 +4        SET ORY=$PIECE(ORITM,U,1,2)

           if (ORPMENU'>0)!(ORPITEM'>0)

               GOTO XQ

 +5        SET OLDPOS=$$FINDXUTL^ORCMEDT1(ORPMENU,ORPITEM)

           if OLDPOS'>0

               GOTO XQ

 +6        SET XUTL=$GET(^XUTL("XQORM",ORPMENU_";ORD(101,",OLDPOS,0))

 +7        if $PIECE(XUTL,U,2)=ORPITEM

               SET ORY=ORY_U_$PIECE(XUTL,U,4)_U_$SELECT($PIECE(XUTL,U,3)'=$PIECE($GET(^ORD(101.41,ORDITEM,0)),U,2):$PIECE(XUTL,U,3),1:"")

XQ         QUIT ORY

 +1       ;

CKDLG     ; -- ck ORDITEM for bad data

 +1        if '$DATA(^ORD(101.41,ORDITEM,10))

               QUIT

           NEW ORIDX,OROOT,ORP,ORI

 +2        SET ORIDX="^ORD(101.41,"_ORDITEM_",10,""A"")"

           SET OROOT="^ORD(101.41,"_ORDITEM_",10,"""

 +3        FOR

               SET ORIDX=$QUERY(@ORIDX)

               if $EXTRACT(ORIDX,1,$LENGTH(OROOT))'=OROOT

                   QUIT

               Begin DoDot:1

 +4       ;last piece=DA

                   SET ORP=$LENGTH(ORIDX,",")

                   SET ORI=+$PIECE(ORIDX,",",ORP)

 +5                IF ORI=ORDA

                       KILL @ORIDX

               End DoDot:1

 +6        QUIT

ORY57.m