Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ORY569

ORY569.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1.  ;
  1.  ; Reference to ^LAB(69.73, in ICR #7216
  1.  ;
  1.  Q
  1.  ;
  1.  ;
  1. POST ;
  1.  ;
  1.  N ORFILENUM,ORROOT
  1.  ;
  1.  ; move over data from 69.73 to 101.45
  1.  I $O(^LAB(69.73,0)),'$O(^ORD(101.45,0)) D
  1.  . D BMES("Moving over data from 69.73 to 101.45.")
  1.  . M ^ORD(101.45)=^LAB(69.73)
  1.  . ; update 0 node with new name and file number
  1.  . S $P(^ORD(101.45,0),U,1)="AP DIALOG CONFIG"
  1.  . S ORFILENUM=$P(^ORD(101.45,0),U,2)
  1.  . S $P(^ORD(101.45,0),U,2)=101.45_$E(ORFILENUM,6,$L(ORFILENUM))
  1.  . ;
  1.  . ; now replace references to 69.73 in 0 node of multiples
  1.  . S ORROOT=$NA(^ORD(101.45))
  1.  . F  S ORROOT=$Q(@ORROOT) Q:ORROOT=""  Q:$QS(ORROOT,1)'=101.45  D
  1.  . . I $QS(ORROOT,$QL(ORROOT))'=0 Q   ;only look for 0 nodes
  1.  . . I $P(@ORROOT,U,1)'="" Q  ; 1st piece must be null
  1.  . . S ORFILENUM=$P(@ORROOT,U,2)
  1.  . . I ORFILENUM'[69.73 Q  ;2nd piece must contain 69.73
  1.  . . S $P(@ORROOT,U,2)=101.45_$E(ORFILENUM,6,$L(ORFILENUM))
  1.  . ;
  1.  . ; Convert file to new format
  1.  . D BMES("Converting AP DIALOG CONFIG File (#101.45)...")
  1.  . D CONVERT,REINDEX
  1.  ; Update file even if it's already installed
  1.  D BMES("Updating AP DIALOG CONFIG File (#101.45)...")
  1.  D UPDATE
  1.  D BMES("Done")
  1.  ;
  1.  D TASK
  1.  ;
  1.  Q
  1.  ;
  1.  ;
  1. TASK ; Task - AP Order Dialog - Make OPSPH Required
  1.  ;
  1.  N ZTDTH,ZTSAVE,ZTIO,ZTSK,ZTRTN,ZTDESC,ZTUCI,ZTCPU,ZTSYNC,ZTKIL
  1.  ;
  1.  S ZTRTN="UPDOPSPH^ORY569"
  1.  S ZTDESC="AP Order Dialog - Make OPSPH Required"
  1.  S ZTIO=""
  1.  S ZTDTH=$H
  1.  D ^%ZTLOAD
  1.  I $G(ZTSK) D BMES("""AP Order Dialog - Make Provider Required"" has been queued, task number "_ZTSK)
  1.  I '$G(ZTSK) D BMES("ERROR: ""AP Order Dialog - Make Provider Required"" failed to queue. Please enter a SNOW ticket.")
  1.  ;
  1.  Q
  1.  ;
  1.  ;
  1. CONVERT ; Convert file - Move Orderable Item pointer from .01 field to .04 field
  1.  N I,X0,IDX,NAME
  1.  S I=0
  1.  F  S I=$O(^ORD(101.45,I)) Q:'I  S X0=$G(^ORD(101.45,I,0)) I X0'="" D
  1.  . S NAME="",IDX=$P(X0,U) I $P(X0,U,4)="" D
  1.  . . I +IDX>0 S NAME=$P($G(^ORD(101.43,IDX,0)),U)
  1.  . . I NAME="" S NAME=IDX
  1.  . . S $P(X0,U,1)=NAME,$P(X0,U,4)=IDX
  1.  . . S ^ORD(101.45,I,0)=X0
  1.  Q
  1.  ;
  1. REINDEX ; Rebuild cross references
  1.  N DA,DIK
  1.  K ^ORD(101.45,"B"),^ORD(101.45,"C")
  1.  S DIK="^ORD(101.45," D IXALL^DIK
  1.  Q
  1.  ;
  1. UPDATE ; Update File Contents
  1.  N IDX,PAGE,X0,RID,NAME,ID,PNAME,NAT,ISNAT
  1.  S RID("Clinical History")="CLINHX"
  1.  S RID("Pre-Operative Diagnosis")="PREOPDX"
  1.  S RID("Operative Findings")="OPFIND"
  1.  S RID("Post-Operative Findings")="POSTOPDX"
  1.  S NAT="^BONE MARROW^BRONCHIAL BIOPSY^BRONCHIAL CYTOLOGY^DERMATOLOGY^FINE NEEDLE ASPIRATE^GASTROINTESTINAL ENDOSCOPY"
  1.  S NAT=NAT_"^GENERAL FLUID^GYNECOLOGY (PAP SMEAR)^RENAL BIOPSY^TISSUE EXAM^URINE^UROLOGY,BLADDER/URETER^UROLOGY,PROSTATE^"
  1.  S IDX=0 F  S IDX=$O(^ORD(101.45,IDX)) Q:'IDX  D
  1.  . S X0=$G(^ORD(101.45,IDX,0)),NAME=$P(X0,U),ISNAT=(NAT[(U_NAME_U))
  1.  . I ISNAT'=$P(X0,U,5) S $P(^ORD(101.45,IDX,0),U,5)=ISNAT
  1.  . S PAGE=0 F  S PAGE=$O(^ORD(101.45,IDX,2,PAGE)) Q:'PAGE  D
  1.  . . S X0=$G(^ORD(101.45,IDX,2,PAGE,0)),PNAME=$P(X0,U,2),ID=$P(X0,U,5)
  1.  . . I PNAME'="",$D(RID(PNAME)),ID'=RID(PNAME) D
  1.  . . . S $P(^ORD(101.45,IDX,2,PAGE,0),U,5)=RID(PNAME)
  1.  . . . D BMES(NAME_" Page "_PAGE_" ("_PNAME_") RESPONSE ID set to "_RID(PNAME))
  1.  Q
  1.  ;
  1.  ;
  1. UPDOPSPH  ; Tasked job to make the OPSPH-Surgeon/Provider Order Prompt Required, once OR*3*405 is installed
  1.  ;
  1.  ; ZEXCEPT: ZTREQ
  1.  N OR0,ORFDA,ORHIDE,ORIEN,ORREQUIRED,ORSPHIEN
  1.  ;
  1.  ; If this task is still tasked by 10/1/23 than something went wrong
  1.  ; with the expected v32b release, and stop requeuing it
  1.  I $$DT^XLFDT>3231001 D  Q
  1.  . S ZTREQ="@"
  1.  ;
  1.  ; v32b still not installed; reschedule to try again T+1@04:00
  1.  I '$$PATCH^XPDUTL("OR*3.0*405") D  Q
  1.  . S ZTREQ=$$FMADD^XLFDT($$DT^XLFDT,1,4,0,0)
  1.  ;
  1.  ; v32b is installed. Update the Surgeon/Provider Order Prompt and make it Required
  1.  ;
  1.  S ZTREQ="@"
  1.  ;
  1.  S ORIEN=0
  1.  F  S ORIEN=$O(^ORD(101.45,ORIEN)) Q:'ORIEN  D
  1.  . I '$P(^ORD(101.45,ORIEN,0),U,5) Q  ; Quit if not national entry
  1.  . ;
  1.  . S ORSPHIEN=$O(^ORD(101.45,ORIEN,1,"B","OPSPH",0))
  1.  . ;
  1.  . I ORSPHIEN D  Q
  1.  . . S OR0=$G(^ORD(101.45,ORIEN,1,ORSPHIEN,0))
  1.  . . S ORHIDE=$P(OR0,U,2)
  1.  . . S ORREQUIRED=$P(OR0,U,3)
  1.  . . I ORHIDE S ORFDA(101.451,ORSPHIEN_","_ORIEN_",",.02)="@"
  1.  . . I 'ORREQUIRED S ORFDA(101.451,ORSPHIEN_","_ORIEN_",",.03)=1
  1.  . . I $D(ORFDA) D FILE^DIE("","ORFDA")
  1.  . ;
  1.  . I 'ORSPHIEN D  Q
  1.  . . S ORFDA(101.451,"+1,"_ORIEN_",",.01)="OPSPH"
  1.  . . S ORFDA(101.451,"+1,"_ORIEN_",",.03)=1
  1.  . . D UPDATE^DIE("","ORFDA")
  1.  ;
  1.  Q
  1.  ;
  1. BMES(STR) ;
  1.  ; Write string
  1.  N OUTPUT,IDX,TAG1,TAG2
  1.  S TAG2="MES^XPDUTL($$TRIM^XLFSTR($$CJ^XLFSTR(OUTPUT(IDX),$G(IOM,80)),""R"","" ""))"
  1.  S TAG1="B"_TAG2
  1.  D WRAP^ORUTL(STR,"OUTPUT",1,0,2,0,78)
  1.  S IDX=0 F  S IDX=$O(OUTPUT(IDX)) Q:'IDX  D
  1.  . I IDX=1 D @TAG1  I 1
  1.  . E  D @TAG2
  1.  Q