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

BLR138PO.m

Go to the documentation of this file. 
  1. BLR138PO ; IHS/MSC/MKK - Modified version of LR*5.2*138 Post Install Routine ;   [ 09/30/2012  8:00 AM ]
  1.  ;;5.2;IHS LABORATORY;**1031**;NOV 01, 1997
  1.  ;
  1.  ; This routine will just create the OOS division in the
  1.  ; HOSPITAL LOCATION (#44) file, and, if successful,
  1.  ; will also update the DEFAULT OOS LOCATION field in
  1.  ; the Laboratory Site (#69.9) file.
  1.  ;
  1.  ; It does utilize a lot of the code from the LR138PO,
  1.  ; LRCAPPH2, and SCDXUAPI routines.
  1.  ;
  1.  ; The reason the code had to be cloned and modified is that
  1.  ;      (1) the search for the LAB entry in the Package (#9.4)
  1.  ;          file was using the wrong index, so it had to be
  1.  ;          corrected, and
  1.  ;      (2) needed to make sure the check for an OOS 'stop
  1.  ;          code' was not used.
  1.  ;
  1. EN ;Builds Laboratory OOS Location
  1.  ;
  1.  D BMES^XPDUTL("Creating OOS Location in File 44")
  1.  ;
  1. LOCMAKE ;
  1.  S LRPKG=$O(^DIC(9.4,"C","LR",0))
  1.  I 'LRPKG S LRPKG=$O(^DIC(9.4,"B","LAB SERVICE",0))
  1.  I 'LRPKG D  G END
  1.  . D BMES^XPDUTL("*** Not able to find 'LAB SERVICE' in your Package (#9.4) file. ***")
  1.  . D BMES^XPDUTL("*** Contact the IHS/OIT Helpdesk. POST INSTALL ABORTED!!        ***")
  1.  . S XPDQUIT=2
  1.  ;
  1.  D BMES^XPDUTL("Creating Laboratory OOS Workload Locations")
  1.  ;
  1. SET S LROK=""
  1.  S LRVN=$O(^LRO(67.9,0)) I LRVN S LRDIVN=LRVN D LK I $G(LROK)>0 S ^LAB(69.9,1,.8)=LROK
  1.  I $G(LROK)>0 S LRVN1=0 F  S LRVN1=$O(^LRO(67.9,LRVN,1,LRVN1)) Q:LRVN1<1  S LRDIVN=LRVN1 D LK
  1.  S LRDIVN=+$$SITE^VASITE I LRDIVN D LK I $G(LROK)>0,'$G(^LAB(69.9,1,.8)) S ^(.8)=LROK
  1.  I $G(^LAB(69.9,1,.8)) D  G END
  1.  . S STR=$$GET1^DIQ(69.9,"1,",.8)
  1.  . D BMES^XPDUTL("DEFAULT LAB OOS LOCATION IS "_STR)
  1.  ;
  1.  S STR=$TR($J("",IOM)," ","=")
  1.  D BMES^XPDUTL(STR)
  1.  D MES^XPDUTL(STR)
  1.  D BMES^XPDUTL("*** Not able to create LAB OOS Location in File 44!!     ***")
  1.  D BMES^XPDUTL("*** Contact the IHS/OIT Helpdesk. POST INSTALL ABORTED!! ***")
  1.  D BMES^XPDUTL(STR)
  1.  D MES^XPDUTL(STR)
  1.  S XPDQUIT=2
  1.  Q
  1.  ;
  1. END ;
  1.  Q:$G(LRDBUG)
  1.  K DA,DATA,DIE,DIK,DIC,DR,LRDIV,LRDIVN,LRNAME,LROK,LRPKG,LRSCODE,LRVN
  1.  K LRVN1,X
  1.  Q
  1.  ;
  1. LK ;
  1.  Q:$G(LRSDCX)
  1.  ;
  1.  NEW BLROUT
  1.  S LRDIV=$S($G(^DIC(4,LRDIVN,99)):$P(^(99),U),1:LRDIVN)
  1.  D FIND^DIC(40.7,,,,"LABORATORY SERVICES",,,,,"BLROUT")
  1.  S LRSCODE=+$G(BLROUT("DILIST","ID",1,1))
  1.  I LRSCODE<1 D  Q
  1.  . D BMES^XPDUTL("*** 'LABORATORY SERVICES' NOT in File 40.7. ***")
  1.  . D BMES^XPDUTL("*** POST INSTALL ABORTED!!                  ***")
  1.  L
  1.  S LRNAME="LAB DIV "_LRDIV_" OOS ID "_LRSCODE
  1.  D LOADB
  1.  Q
  1.  ;
  1.  ; Following code cloned from LOADB^LRCAPPH2
  1. LOADB S LRNAME=$E(LRNAME,1,30) Q:$D(^SC("B",LRNAME))
  1.  ;S X="SCDXUAPI" X ^%ZOSF("TEST") I '$T W !!,$$CJ^XLFSTR("Load SD*5.3*63 Patch",80),!! Q
  1.  S X="SCDXUAPI" X ^%ZOSF("TEST") Q:'$T  ;IHS/DIR TUC/AAB 07/09/98
  1.  S LROK=$$LOC(LRNAME,LRDIVN,LRSCODE,LRPKG,,)
  1.  I $G(LRDBUG) W !,"LROK = ",LROK
  1.  I LROK<1  D BMES^XPDUTL("*** "_$P(LROK,U,2)_" LOCATION NOT CREATED. ***")  Q
  1.  ;
  1.  D SHOW^LRCAPPH2
  1.  D BMES^XPDUTL("LAB Location Added.")
  1.  Q:$G(LRDBUG)  K DIC,DIE,DA,DIR
  1.  Q
  1.  ;
  1.  ; Following code cloned from LOC^SCDXUAPI
  1. LOC(NAME,INST,STOP,PKG,IEN,INACT) ; add/edit location for ancillary app
  1.  ;
  1.  ; Description:
  1.  ; This call will accept the name, division, and stop code (DSS ID)
  1.  ; of the clinic location to be add/edited.  If the IEN is passed in,
  1.  ; the entry with that IEN will be updated.  Otherwise, a new entry will
  1.  ; be added.  If the INACT variable is set to a date, it will INACTIVATE
  1.  ; the location (if it exists).
  1.  ;
  1.  ;  Input:  NAME of clinic to be created (optional)
  1.  ;          INST as pointer to the institution file (optional)
  1.  ;          STOP as number of stop code (not IEN) for
  1.  ;                occasion of service range of codes (optional)
  1.  ;          PKG as package file IEN, name, or namespace - required!
  1.  ;          IEN as IEN of location if you want to update an already
  1.  ;                existing location (optional.  If not defined, NAME,
  1.  ;                INST, STOP become required)
  1.  ;          INACT as a date if you want to inactivate the location that
  1.  ;                has the IEN you defined (optional)
  1.  ;
  1.  ; Output:  IEN of location created/inactivated - OR - 
  1.  ;          -1^error message if problem encountered
  1.  N ERR,I,SCERR,X
  1.  S PKG=$$PKGIEN(PKG)
  1.  F I="NAME","INST","STOP","INACT","IEN","PKG" I $G(@I) S SCERR(I)=@I
  1.  S ERR=$$ERRCHK(.SCERR)
  1.  I ERR]"" G LOCQ
  1.  I $D(STOP) S STOP=$O(^DIC(40.7,"C",+STOP,0)) I 'STOP S Y=$$ERR(6) G LOCQ
  1.  I $G(IEN)]"" D
  1.  . N X
  1.  . S X=$G(^SC(IEN,"OOS"))
  1.  . I X,($P(X,"^",2)=PKG) D EDIT(IEN,$G(NAME),$G(INST),$G(STOP),PKG,$G(INACT)) Q
  1.  . S ERR=$$ERR(7)
  1.  E  D
  1.  . F I="NAME","INST","STOP" I @I']"" S ERR=$$ERR(8) Q
  1.  . S IEN=$$ADD(NAME,PKG) I IEN'>0 S ERR=$$ERR(9) Q
  1.  . D EDIT(IEN,NAME,INST,STOP,PKG)
  1. LOCQ Q $S(ERR]"":ERR,1:IEN)
  1.  ;
  1.  ;
  1. ERRCHK(SC,RAD) ; check input variables for consistency
  1.  ;
  1.  ; if RAD defined, don't check division/institution
  1.  ;
  1.  N LOC,OK,X,Y
  1.  S Y=""
  1.  I $D(SC("IEN")) D  I +Y<0 G ERRCHKQ
  1.  . N IEN
  1.  . S IEN=SC("IEN")
  1.  . S LOC=$G(^SC(+IEN,0))
  1.  . I LOC']"" S Y=$$ERR(1) Q                                ; invalid ptr
  1.  . I '$G(RAD),'$D(^DIC(4,+$G(SC("INST")),0)) D  I Y]"" Q
  1.  . . I '$P(LOC,"^",4),'$P(LOC,"^",15) S Y=$$ERR(2) Q       ; bad inst/div
  1.  . S X=$G(^SC(IEN,"I"))
  1.  . I +X,('$P(X,"^",2)!($P(X,"^",2)>DT)) S Y=$$ERR(3) Q     ; inactive
  1.  . S X=$G(^SC(IEN,"OOS"))
  1.  . I +X,($P(X,"^",2)'=SC("PKG")) S Y=$$ERR(5) Q            ; wrong pkg
  1.  I PKG'>0 S Y=$$ERR(4) G ERRCHKQ                           ; pkg invalid
  1.  I $D(SC("STOP")) D  I Y]"" G ERRCHKQ
  1.  . N STOP
  1.  . S STOP=SC("STOP")
  1.  . S STOP=$O(^DIC(40.7,"C",+STOP,0))
  1.  . I 'STOP S Y=$$ERR(6) Q                                  ; bad stop code
  1.  . ; I '$$EX^SDCOU2(+STOP) S Y=$$ERR(10) Q                   ; not oos stop
  1. ERRCHKQ Q Y
  1.  ;
  1.  ;
  1. NONCOUNT(IEN) ; convert location to non-count
  1.  ;
  1.  ;  Input:  IEN of location to convert
  1.  ; Output:  none
  1.  ;
  1.  N DA,DIE,DR
  1.  S DIE="^SC(",DA=IEN,DR="2502////Y"
  1.  D ^DIE
  1.  Q
  1.  ;
  1.  ;
  1. UPD(IEN,PKG) ; update existing entry
  1.  ;
  1.  ;  Called from within routine only...not supported
  1.  ;  Input:  IEN as IEN of location to update
  1.  ;          PKG as calling package
  1.  ;
  1.  N SC
  1.  D VAR(IEN,.SC)
  1.  D EDIT(IEN,SC("NAME"),SC("INST"),SC("STOP"),PKG)
  1.  Q
  1.  ;
  1.  ;
  1. NEW(IEN,PKG) ; create new entry given parameters from existing entry
  1.  ;
  1.  ;  Called from within routine only...not supported
  1.  ;  Input:  IEN as IEN of location to update
  1.  ;          PKG as calling package
  1.  ;
  1.  N SC
  1.  D VAR(IEN,.SC)
  1.  S IEN=$$ADD(SC("NAME"),PKG)
  1.  D EDIT(IEN,SC("NAME"),SC("INST"),SC("STOP"),PKG)
  1.  Q IEN
  1.  ;
  1.  ;
  1.  ;
  1. VAR(IEN,SC) ; set up variables for ADD and EDIT calls based on existing entry
  1.  ;
  1.  ;  Input:  IEN as IEN of existing location
  1.  ; Output:  SC("NAME") as name of location
  1.  ;          SC("INST") as institution file ptr
  1.  ;          SC("STOP") as IEN of clinic stop file
  1.  ;
  1.  N DIV,X
  1.  S X=$G(^SC(+$G(IEN),0))
  1.  S SC("NAME")=$P(X,"^",1)
  1.  S SC("STOP")=$P(X,"^",7)
  1.  I $P(X,"^",4) S SC("INST")=$P(X,"^",4) G VARQ
  1.  S DIV=$P(X,"^",15),SC("INST")=$P($G(^DG(40.8,+DIV,0)),"^",7)
  1. VARQ Q
  1.  ;
  1.  ;
  1. PKGIEN(PKG) ; get IEN of package file entry
  1.  ;
  1.  ;  Input:  PKG as IEN, name, or abbreviation of PKG
  1.  ; Output:  IEN of package file
  1.  ;
  1.  N Y
  1.  S PKG=$G(PKG)
  1.  I PKG']"" S Y=-1 G PKGIENQ
  1.  I PKG S Y=PKG G PKGIENQ
  1.  S Y=$O(^DIC(9.4,"C",PKG,0)) I Y G PKGIENQ
  1.  S Y=$O(^DIC(9.4,"B",PKG,0)) I Y G PKGIENQ
  1.  S Y=-1
  1. PKGIENQ Q Y
  1.  ;
  1.  ;
  1. DIV(INST) ; return division associated with institution
  1.  Q $O(^DG(40.8,"AD",+INST,0))
  1.  ;
  1.  ;
  1. CHK(IEN) ; check to see if patterns exist for IEN
  1.  ;
  1.  ;  Input:  IEN of hospital location file
  1.  ; Output:  1 if ok (no patterns exist); 0 otherwise
  1.  ;
  1.  N I,OK
  1.  S OK=1
  1.  I $G(^SC(IEN,"SL"))]"" S OK=0 G CHKQ
  1.  I $O(^SC(IEN,"ST",0)) S OK=0 G CHKQ
  1.  I $O(^SC(IEN,"T",0)) S OK=0 G CHKQ
  1.  F I=0:1:6 I $O(^SC(IEN,"T"_I,0)) S OK=0 Q
  1. CHKQ Q OK
  1.  ;
  1.  ;
  1. ADD(SCNAME,SCPKG) ; add new entry
  1.  ;
  1.  N DD,DIC,DINUM,DO,X,Y
  1.  S DIC="^SC(",X=SCNAME,DIC(0)="L"
  1.  S DIC("DR")="50.01////1;50.02////^S X=$$PKGIEN^SCDXUAPI(SCPKG);"
  1.  D FILE^DICN
  1.  Q +Y
  1.  ;
  1. EDIT(SCIEN,SCNAME,SCINST,SCSTOP,SCPKG,SCINACT) ; update fields
  1.  ;
  1.  N DA,DIE,DR,INST,X
  1.  S DIE="^SC(",DA=SCIEN,DR=""
  1.  I $G(SCNAME)]"" S DR=DR_".01///^S X=SCNAME;"    ; name
  1.  S DR=DR_"2////C;"                               ; type = clinic
  1.  I $G(SCINST)]"" D
  1.  . S DR=DR_"3////^S X=SCINST;"                   ; inst ptr
  1.  . S DR=DR_"3.5////^S X=$$DIV^SCDXUAPI(SCINST);" ; division
  1.  I $G(SCSTOP)]"" S DR=DR_"8////^S X=SCSTOP;"     ; stop code
  1.  S DR=DR_"2504////Y;"                            ; clinic meets here
  1.  S DR=DR_"9////0;"                               ; service=none
  1.  S DR=DR_"2502////N;"                            ; non-count=no
  1.  S DR=DR_"2502.5////0;"                          ; on fileroom list = no
  1.  S DR=DR_"26////1;"                              ; ask provider = yes
  1.  S DR=DR_"27////0;"                              ; ask diagnosis = no
  1.  S DR=DR_"2500////Y;"                            ; prohibit access=yes
  1.  S DR=DR_"50.01////1;"                           ; occasion of serv loc
  1.  S DR=DR_"50.02////^S X=$$PKGIEN^SCDXUAPI(SCPKG);"  ; calling pkg
  1.  I $G(SCINACT) D
  1.  . S DR=DR_"2505////^S X=SCINACT;"              ; inact date
  1.  . S DR=DR_"2506///@;"                          ; remove react date
  1.  D ^DIE
  1.  Q
  1.  ;
  1.  ;
  1. ERR(NUMBER) ; return error message corresponding to the number passed in
  1.  ;
  1.  ;  Input:  NUMBER of error message to return
  1.  ; Output:  -1^NUMBER^Error Message Text
  1.  ;
  1.  Q "-1^"_NUMBER_"^"_$P($T(ERRORS+NUMBER),";;",2)
  1.  ;
  1.  ;
  1. ERRORS ; list of error messages
  1.  ;;Hospital Location IEN is Invalid
  1.  ;;Neither institution nor division defined properly for existing entry
  1.  ;;Location has an inactivation date
  1.  ;;Invalid PKG variable passed in
  1.  ;;IEN belongs to another package (PKG file entries don't match)
  1.  ;;Invalid stop code passed
  1.  ;;Invalid IEN passed to LOC call (package doesn't 'own' IEN)
  1.  ;;NAME, INST, and STOP not all defined before LOC call when IEN not set
  1.  ;;Unable to add entry to Hospital Location file
  1.  ;;Stop code not an occassion of service stop
  1.  ;
  1.  ;
  1. SCREEN(PKG) ; screen to only allow OOS locations for specified package
  1.  Q "I +$G(^(""OOS"")),($P(^(""OOS""),""^"",2)="_$$PKGIEN(PKG)_")"
  1.  ;
  1. EXEMPT() ; screen on clinic stop file to select only OOS stops
  1.  Q "I $$EX^SDCOU2(+Y)"
  1.  ;
  1. PKGNM(SCPKG) ; Return Name of Package
  1.  ;  Input:     SCPKG - Pointer to Package File (9.4)
  1.  ;  Returned:  Name of Package or 'Bad or Missing Pointer'
  1.  ;
  1.  N SCOS
  1.  D:$G(SCPKG) GETS^DIQ(9.4,SCPKG,.01,"E","SCOS")
  1.  Q $S($D(SCOS(9.4,(+$G(SCPKG))_",",.01,"E")):SCOS(9.4,(+$G(SCPKG))_",",.01,"E"),1:"Bad or Missing Pointer")