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)
Q
;
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
Q
;
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
Q
;
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
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORY57 2273 printed Sep 23, 2025@20:19:07 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
