ORY569 ;ISP/LMT - OR*3*569 Post-Install ;Jul 13, 2022@14:02:50
;;3.0;ORDER ENTRY/RESULTS REPORTING;**569**;Dec 17, 1997;Build 23
;
;
; Reference to ^LAB(69.73, in ICR #7216
;
Q
;
;
POST ;
;
N ORFILENUM,ORROOT
;
; move over data from 69.73 to 101.45
I $O(^LAB(69.73,0)),'$O(^ORD(101.45,0)) D
. D BMES("Moving over data from 69.73 to 101.45.")
. M ^ORD(101.45)=^LAB(69.73)
. ; update 0 node with new name and file number
. S $P(^ORD(101.45,0),U,1)="AP DIALOG CONFIG"
. S ORFILENUM=$P(^ORD(101.45,0),U,2)
. S $P(^ORD(101.45,0),U,2)=101.45_$E(ORFILENUM,6,$L(ORFILENUM))
. ;
. ; now replace references to 69.73 in 0 node of multiples
. S ORROOT=$NA(^ORD(101.45))
. F S ORROOT=$Q(@ORROOT) Q:ORROOT="" Q:$QS(ORROOT,1)'=101.45 D
. . I $QS(ORROOT,$QL(ORROOT))'=0 Q ;only look for 0 nodes
. . I $P(@ORROOT,U,1)'="" Q ; 1st piece must be null
. . S ORFILENUM=$P(@ORROOT,U,2)
. . I ORFILENUM'[69.73 Q ;2nd piece must contain 69.73
. . S $P(@ORROOT,U,2)=101.45_$E(ORFILENUM,6,$L(ORFILENUM))
. ;
. ; Convert file to new format
. D BMES("Converting AP DIALOG CONFIG File (#101.45)...")
. D CONVERT,REINDEX
; Update file even if it's already installed
D BMES("Updating AP DIALOG CONFIG File (#101.45)...")
D UPDATE
D BMES("Done")
;
D TASK
;
Q
;
;
TASK ; Task - AP Order Dialog - Make OPSPH Required
;
N ZTDTH,ZTSAVE,ZTIO,ZTSK,ZTRTN,ZTDESC,ZTUCI,ZTCPU,ZTSYNC,ZTKIL
;
S ZTRTN="UPDOPSPH^ORY569"
S ZTDESC="AP Order Dialog - Make OPSPH Required"
S ZTIO=""
S ZTDTH=$H
D ^%ZTLOAD
I $G(ZTSK) D BMES("""AP Order Dialog - Make Provider Required"" has been queued, task number "_ZTSK)
I '$G(ZTSK) D BMES("ERROR: ""AP Order Dialog - Make Provider Required"" failed to queue. Please enter a SNOW ticket.")
;
Q
;
;
CONVERT ; Convert file - Move Orderable Item pointer from .01 field to .04 field
N I,X0,IDX,NAME
S I=0
F S I=$O(^ORD(101.45,I)) Q:'I S X0=$G(^ORD(101.45,I,0)) I X0'="" D
. S NAME="",IDX=$P(X0,U) I $P(X0,U,4)="" D
. . I +IDX>0 S NAME=$P($G(^ORD(101.43,IDX,0)),U)
. . I NAME="" S NAME=IDX
. . S $P(X0,U,1)=NAME,$P(X0,U,4)=IDX
. . S ^ORD(101.45,I,0)=X0
Q
;
REINDEX ; Rebuild cross references
N DA,DIK
K ^ORD(101.45,"B"),^ORD(101.45,"C")
S DIK="^ORD(101.45," D IXALL^DIK
Q
;
UPDATE ; Update File Contents
N IDX,PAGE,X0,RID,NAME,ID,PNAME,NAT,ISNAT
S RID("Clinical History")="CLINHX"
S RID("Pre-Operative Diagnosis")="PREOPDX"
S RID("Operative Findings")="OPFIND"
S RID("Post-Operative Findings")="POSTOPDX"
S NAT="^BONE MARROW^BRONCHIAL BIOPSY^BRONCHIAL CYTOLOGY^DERMATOLOGY^FINE NEEDLE ASPIRATE^GASTROINTESTINAL ENDOSCOPY"
S NAT=NAT_"^GENERAL FLUID^GYNECOLOGY (PAP SMEAR)^RENAL BIOPSY^TISSUE EXAM^URINE^UROLOGY,BLADDER/URETER^UROLOGY,PROSTATE^"
S IDX=0 F S IDX=$O(^ORD(101.45,IDX)) Q:'IDX D
. S X0=$G(^ORD(101.45,IDX,0)),NAME=$P(X0,U),ISNAT=(NAT[(U_NAME_U))
. I ISNAT'=$P(X0,U,5) S $P(^ORD(101.45,IDX,0),U,5)=ISNAT
. S PAGE=0 F S PAGE=$O(^ORD(101.45,IDX,2,PAGE)) Q:'PAGE D
. . S X0=$G(^ORD(101.45,IDX,2,PAGE,0)),PNAME=$P(X0,U,2),ID=$P(X0,U,5)
. . I PNAME'="",$D(RID(PNAME)),ID'=RID(PNAME) D
. . . S $P(^ORD(101.45,IDX,2,PAGE,0),U,5)=RID(PNAME)
. . . D BMES(NAME_" Page "_PAGE_" ("_PNAME_") RESPONSE ID set to "_RID(PNAME))
Q
;
;
UPDOPSPH ; Tasked job to make the OPSPH-Surgeon/Provider Order Prompt Required, once OR*3*405 is installed
;
; ZEXCEPT: ZTREQ
N OR0,ORFDA,ORHIDE,ORIEN,ORREQUIRED,ORSPHIEN
;
; If this task is still tasked by 10/1/23 than something went wrong
; with the expected v32b release, and stop requeuing it
I $$DT^XLFDT>3231001 D Q
. S ZTREQ="@"
;
; v32b still not installed; reschedule to try again T+1@04:00
I '$$PATCH^XPDUTL("OR*3.0*405") D Q
. S ZTREQ=$$FMADD^XLFDT($$DT^XLFDT,1,4,0,0)
;
; v32b is installed. Update the Surgeon/Provider Order Prompt and make it Required
;
S ZTREQ="@"
;
S ORIEN=0
F S ORIEN=$O(^ORD(101.45,ORIEN)) Q:'ORIEN D
. I '$P(^ORD(101.45,ORIEN,0),U,5) Q ; Quit if not national entry
. ;
. S ORSPHIEN=$O(^ORD(101.45,ORIEN,1,"B","OPSPH",0))
. ;
. I ORSPHIEN D Q
. . S OR0=$G(^ORD(101.45,ORIEN,1,ORSPHIEN,0))
. . S ORHIDE=$P(OR0,U,2)
. . S ORREQUIRED=$P(OR0,U,3)
. . I ORHIDE S ORFDA(101.451,ORSPHIEN_","_ORIEN_",",.02)="@"
. . I 'ORREQUIRED S ORFDA(101.451,ORSPHIEN_","_ORIEN_",",.03)=1
. . I $D(ORFDA) D FILE^DIE("","ORFDA")
. ;
. I 'ORSPHIEN D Q
. . S ORFDA(101.451,"+1,"_ORIEN_",",.01)="OPSPH"
. . S ORFDA(101.451,"+1,"_ORIEN_",",.03)=1
. . D UPDATE^DIE("","ORFDA")
;
Q
;
BMES(STR) ;
; Write string
N OUTPUT,IDX,TAG1,TAG2
S TAG2="MES^XPDUTL($$TRIM^XLFSTR($$CJ^XLFSTR(OUTPUT(IDX),$G(IOM,80)),""R"","" ""))"
S TAG1="B"_TAG2
D WRAP^ORUTL(STR,"OUTPUT",1,0,2,0,78)
S IDX=0 F S IDX=$O(OUTPUT(IDX)) Q:'IDX D
. I IDX=1 D @TAG1 I 1
. E D @TAG2
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORY569 4870 printed Nov 22, 2024@17:52:55 Page 2
ORY569 ;ISP/LMT - OR*3*569 Post-Install ;Jul 13, 2022@14:02:50
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**569**;Dec 17, 1997;Build 23
+2 ;
+3 ;
+4 ; Reference to ^LAB(69.73, in ICR #7216
+5 ;
+6 QUIT
+7 ;
+8 ;
POST ;
+1 ;
+2 NEW ORFILENUM,ORROOT
+3 ;
+4 ; move over data from 69.73 to 101.45
+5 IF $ORDER(^LAB(69.73,0))
IF '$ORDER(^ORD(101.45,0))
Begin DoDot:1
+6 DO BMES("Moving over data from 69.73 to 101.45.")
+7 MERGE ^ORD(101.45)=^LAB(69.73)
+8 ; update 0 node with new name and file number
+9 SET $PIECE(^ORD(101.45,0),U,1)="AP DIALOG CONFIG"
+10 SET ORFILENUM=$PIECE(^ORD(101.45,0),U,2)
+11 SET $PIECE(^ORD(101.45,0),U,2)=101.45_$EXTRACT(ORFILENUM,6,$LENGTH(ORFILENUM))
+12 ;
+13 ; now replace references to 69.73 in 0 node of multiples
+14 SET ORROOT=$NAME(^ORD(101.45))
+15 FOR
SET ORROOT=$QUERY(@ORROOT)
if ORROOT=""
QUIT
if $QSUBSCRIPT(ORROOT,1)'=101.45
QUIT
Begin DoDot:2
+16 ;only look for 0 nodes
IF $QSUBSCRIPT(ORROOT,$QLENGTH(ORROOT))'=0
QUIT
+17 ; 1st piece must be null
IF $PIECE(@ORROOT,U,1)'=""
QUIT
+18 SET ORFILENUM=$PIECE(@ORROOT,U,2)
+19 ;2nd piece must contain 69.73
IF ORFILENUM'[69.73
QUIT
+20 SET $PIECE(@ORROOT,U,2)=101.45_$EXTRACT(ORFILENUM,6,$LENGTH(ORFILENUM))
End DoDot:2
+21 ;
+22 ; Convert file to new format
+23 DO BMES("Converting AP DIALOG CONFIG File (#101.45)...")
+24 DO CONVERT
DO REINDEX
End DoDot:1
+25 ; Update file even if it's already installed
+26 DO BMES("Updating AP DIALOG CONFIG File (#101.45)...")
+27 DO UPDATE
+28 DO BMES("Done")
+29 ;
+30 DO TASK
+31 ;
+32 QUIT
+33 ;
+34 ;
TASK ; Task - AP Order Dialog - Make OPSPH Required
+1 ;
+2 NEW ZTDTH,ZTSAVE,ZTIO,ZTSK,ZTRTN,ZTDESC,ZTUCI,ZTCPU,ZTSYNC,ZTKIL
+3 ;
+4 SET ZTRTN="UPDOPSPH^ORY569"
+5 SET ZTDESC="AP Order Dialog - Make OPSPH Required"
+6 SET ZTIO=""
+7 SET ZTDTH=$HOROLOG
+8 DO ^%ZTLOAD
+9 IF $GET(ZTSK)
DO BMES("""AP Order Dialog - Make Provider Required"" has been queued, task number "_ZTSK)
+10 IF '$GET(ZTSK)
DO BMES("ERROR: ""AP Order Dialog - Make Provider Required"" failed to queue. Please enter a SNOW ticket.")
+11 ;
+12 QUIT
+13 ;
+14 ;
CONVERT ; Convert file - Move Orderable Item pointer from .01 field to .04 field
+1 NEW I,X0,IDX,NAME
+2 SET I=0
+3 FOR
SET I=$ORDER(^ORD(101.45,I))
if 'I
QUIT
SET X0=$GET(^ORD(101.45,I,0))
IF X0'=""
Begin DoDot:1
+4 SET NAME=""
SET IDX=$PIECE(X0,U)
IF $PIECE(X0,U,4)=""
Begin DoDot:2
+5 IF +IDX>0
SET NAME=$PIECE($GET(^ORD(101.43,IDX,0)),U)
+6 IF NAME=""
SET NAME=IDX
+7 SET $PIECE(X0,U,1)=NAME
SET $PIECE(X0,U,4)=IDX
+8 SET ^ORD(101.45,I,0)=X0
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;
REINDEX ; Rebuild cross references
+1 NEW DA,DIK
+2 KILL ^ORD(101.45,"B"),^ORD(101.45,"C")
+3 SET DIK="^ORD(101.45,"
DO IXALL^DIK
+4 QUIT
+5 ;
UPDATE ; Update File Contents
+1 NEW IDX,PAGE,X0,RID,NAME,ID,PNAME,NAT,ISNAT
+2 SET RID("Clinical History")="CLINHX"
+3 SET RID("Pre-Operative Diagnosis")="PREOPDX"
+4 SET RID("Operative Findings")="OPFIND"
+5 SET RID("Post-Operative Findings")="POSTOPDX"
+6 SET NAT="^BONE MARROW^BRONCHIAL BIOPSY^BRONCHIAL CYTOLOGY^DERMATOLOGY^FINE NEEDLE ASPIRATE^GASTROINTESTINAL ENDOSCOPY"
+7 SET NAT=NAT_"^GENERAL FLUID^GYNECOLOGY (PAP SMEAR)^RENAL BIOPSY^TISSUE EXAM^URINE^UROLOGY,BLADDER/URETER^UROLOGY,PROSTATE^"
+8 SET IDX=0
FOR
SET IDX=$ORDER(^ORD(101.45,IDX))
if 'IDX
QUIT
Begin DoDot:1
+9 SET X0=$GET(^ORD(101.45,IDX,0))
SET NAME=$PIECE(X0,U)
SET ISNAT=(NAT[(U_NAME_U))
+10 IF ISNAT'=$PIECE(X0,U,5)
SET $PIECE(^ORD(101.45,IDX,0),U,5)=ISNAT
+11 SET PAGE=0
FOR
SET PAGE=$ORDER(^ORD(101.45,IDX,2,PAGE))
if 'PAGE
QUIT
Begin DoDot:2
+12 SET X0=$GET(^ORD(101.45,IDX,2,PAGE,0))
SET PNAME=$PIECE(X0,U,2)
SET ID=$PIECE(X0,U,5)
+13 IF PNAME'=""
IF $DATA(RID(PNAME))
IF ID'=RID(PNAME)
Begin DoDot:3
+14 SET $PIECE(^ORD(101.45,IDX,2,PAGE,0),U,5)=RID(PNAME)
+15 DO BMES(NAME_" Page "_PAGE_" ("_PNAME_") RESPONSE ID set to "_RID(PNAME))
End DoDot:3
End DoDot:2
End DoDot:1
+16 QUIT
+17 ;
+18 ;
UPDOPSPH ; Tasked job to make the OPSPH-Surgeon/Provider Order Prompt Required, once OR*3*405 is installed
+1 ;
+2 ; ZEXCEPT: ZTREQ
+3 NEW OR0,ORFDA,ORHIDE,ORIEN,ORREQUIRED,ORSPHIEN
+4 ;
+5 ; If this task is still tasked by 10/1/23 than something went wrong
+6 ; with the expected v32b release, and stop requeuing it
+7 IF $$DT^XLFDT>3231001
Begin DoDot:1
+8 SET ZTREQ="@"
End DoDot:1
QUIT
+9 ;
+10 ; v32b still not installed; reschedule to try again T+1@04:00
+11 IF '$$PATCH^XPDUTL("OR*3.0*405")
Begin DoDot:1
+12 SET ZTREQ=$$FMADD^XLFDT($$DT^XLFDT,1,4,0,0)
End DoDot:1
QUIT
+13 ;
+14 ; v32b is installed. Update the Surgeon/Provider Order Prompt and make it Required
+15 ;
+16 SET ZTREQ="@"
+17 ;
+18 SET ORIEN=0
+19 FOR
SET ORIEN=$ORDER(^ORD(101.45,ORIEN))
if 'ORIEN
QUIT
Begin DoDot:1
+20 ; Quit if not national entry
IF '$PIECE(^ORD(101.45,ORIEN,0),U,5)
QUIT
+21 ;
+22 SET ORSPHIEN=$ORDER(^ORD(101.45,ORIEN,1,"B","OPSPH",0))
+23 ;
+24 IF ORSPHIEN
Begin DoDot:2
+25 SET OR0=$GET(^ORD(101.45,ORIEN,1,ORSPHIEN,0))
+26 SET ORHIDE=$PIECE(OR0,U,2)
+27 SET ORREQUIRED=$PIECE(OR0,U,3)
+28 IF ORHIDE
SET ORFDA(101.451,ORSPHIEN_","_ORIEN_",",.02)="@"
+29 IF 'ORREQUIRED
SET ORFDA(101.451,ORSPHIEN_","_ORIEN_",",.03)=1
+30 IF $DATA(ORFDA)
DO FILE^DIE("","ORFDA")
End DoDot:2
QUIT
+31 ;
+32 IF 'ORSPHIEN
Begin DoDot:2
+33 SET ORFDA(101.451,"+1,"_ORIEN_",",.01)="OPSPH"
+34 SET ORFDA(101.451,"+1,"_ORIEN_",",.03)=1
+35 DO UPDATE^DIE("","ORFDA")
End DoDot:2
QUIT
End DoDot:1
+36 ;
+37 QUIT
+38 ;
BMES(STR) ;
+1 ; Write string
+2 NEW OUTPUT,IDX,TAG1,TAG2
+3 SET TAG2="MES^XPDUTL($$TRIM^XLFSTR($$CJ^XLFSTR(OUTPUT(IDX),$G(IOM,80)),""R"","" ""))"
+4 SET TAG1="B"_TAG2
+5 DO WRAP^ORUTL(STR,"OUTPUT",1,0,2,0,78)
+6 SET IDX=0
FOR
SET IDX=$ORDER(OUTPUT(IDX))
if 'IDX
QUIT
Begin DoDot:1
+7 IF IDX=1
DO @TAG1
IF 1
+8 IF '$TEST
DO @TAG2
End DoDot:1
+9 QUIT
