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

VIABRPC4.m

Go to the documentation of this file. 
  1. VIABRPC4 ;AAC/JMC - VIA RPCs ;10/11/2016
  1.  ;;1.0;VISTA INTEGRATION ADAPTER;**9**;06-FEB-2014;Build 1
  1.  ; ICR 3533     Calls to Routine SROESTV [LIST^SROESTV] (Controlled)
  1.  ; ICR 3969     GMTSROB [STATUS^GMTSROB] (Controlled)
  1.  ; ICR 10090    INSTITUTION FILE [Read File #4] (Supported)
  1.  ; ICR 2343     DBIA2343 [DEA^XUSER, DETOX^XUSER] (Supported)
  1.  ; ICR 2946     Calls to PSSGSGUI [EN^PSSGSGUI] (Controlled)
  1.  ; ICR 4133     IMO QUALIFIER [SDIMO^SDAMA203] (Controlled)
  1.  ; ICR 4422     READ OF AE CROSS REFERENCE [read ^SC("AE"] (Controlled)
  1.  ; ICR 2389     LAB(62 USAGE IN OE/RR [File #62, fields .01;2;3;7;64.9101] (private)
  1.  ; ICR 10055    TOPOGRAPHY FIELD FILE [File #61, field .01] (supported)
  1.  ; ICR 2843     DBIA2843 [File #101.43, Fields .01;2] (controlled)
  1.  ; ICR 6486     NAME: VIA USE OF ORDERABLE ITEMS FILE (101.43) [File 101.43, fields .01,2,8,"S." xref] private
  1.  ; ICR 6730     VIAB SRGY RPTLIST [read fields #.04,15,27,39,49 from File #130] (private)
  1.  ; ICR 6725     VIAB CALL TO FIRST~ORCDPS3 [$$FIRST^ORCDPS3] (private)
  1.  ; ICR 10035    PATIENT FILE {File #2, field .1] (supported)
  1.  ; ICR 3278     DBIA3278 [DSUP^PSOSIGDS] (private)
  1.  ; ICR 4872     SURGERY PROCEDURE/DIAGNOSIS CODES [File #136, field .02] (controlled)
  1.  ; ICR 6484     VIAB USE OF DISPLAY GROUP FILE (100.98) [File #100.98, field .01] (private)
  1.  ;
  1. RPTLIST(RESULT,VIADFN) ;Return list of surgery reports for reports tab; ICR-10141,#10112,#6730,#3533,#3969,#1995,#4872
  1.  ;RPC VIAB SRGY RPTLIST
  1.  ;This RPC is a similar to ORWSR RPTLIST
  1.  Q:'$$PATCH^XPDUTL("SR*3.0*100")
  1.  Q:'+VIADFN
  1.  N VIABDT,VIAEDT,VIAMAX,I,SHOWDOCS,X,SITE,Z,SPEC,GMN,STATUS,DCTDTM,TRSDTM,Y,VIALW,PXDT,C
  1.  S (VIABDT,VIAEDT,VIAMAX)="",SHOWDOCS=0
  1.  S RESULT=$NA(^TMP("VIABLIST",$J))
  1.  S SITE=$$SITE^VASITE,SITE=$P(SITE,"^",2)_";"_$P(SITE,"^",3)
  1.  D LIST^SROESTV(.RESULT,VIADFN,VIABDT,VIAEDT,VIAMAX,SHOWDOCS)
  1.  S I=0
  1.  F  S I=$O(@RESULT@(I)) Q:+I=0  D
  1.  . S PXDT=$P(@RESULT@(I),U,3)
  1.  . S X=$P(@RESULT@(I),U,2),$P(@RESULT@(I),U,2)=$P(@RESULT@(I),U,3),$P(@RESULT@(I),U,3)=X
  1.  . S $P(@RESULT@(I),U,4)=$P($P(@RESULT@(I),U,4),";",2)
  1.  . S GMN=$P(@RESULT@(I),U)
  1.  . ;*347 Use Fileman calls.
  1.  . K VIALW D GETS^DIQ(130,GMN,"49","","VIALW") S Z=$Q(VIALW) S:Z']"" Z="Z" S $P(@RESULT@(I),U,6)="LAB WORK-"_$S($D(@Z)>1:"Yes",1:"No") ; Lab work
  1.  . D STATUS^GMTSROB S:'$D(STATUS) STATUS="UNKNOWN"
  1.  . S $P(@RESULT@(I),U,7)="STATUS-"_STATUS ; op status
  1.  . S Z=$$GET1^DIQ(130,GMN,.04,"I") I Z>0 S Y=Z,C=$P(^DD(130,.04,0),U,2) D Y^DIQ S SPEC=Y K Y
  1.  . S $P(@RESULT@(I),U,8)="SPEC-"_$G(SPEC) ; Surgical specialty
  1.  . S Z=$$GET1^DIQ(136,GMN,.02,"I") I +Z S Z=Z_" "_$P($$CPT^ICPTCOD(Z,PXDT),U,3)
  1.  . S $P(@RESULT@(I),U,11)="PRINPX-"_Z ; Prin Procedure Code
  1.  . ;*347 Reset variables for each item.
  1.  . K SPEC,DCTDTM,TRSDTM,STATUS,Y,Z
  1.  . S @RESULT@(I)=SITE_U_@RESULT@(I)
  1.  Q
  1.  ;
  1. DATE(X) ;convert fm date to readable format with 4 digits in year.
  1.  N VIAX,YY
  1.  S VIAX=X
  1.  S X=$$REGDTM4(X)
  1.  Q X
  1.  ;
  1. REGDTM4(X) ;Receives X in internal date.time, and returns X in MM/DD/YYYY TT:TT
  1.  ; DBIA 10103 call $$FMTE^XLFDT
  1.  Q $TR($$FMTE^XLFDT(X,"5ZM"),"@"," ")
  1.  ;
  1. ON(RESULT) ; returns E if order checking enabled, otherwise D;ICR-#2263
  1.  ;RPC VIABDXC ON
  1.  ;This RPC is a similar to ORWDXC ON
  1.  S RESULT=$$GET^XPAR("DIV^SYS^PKG","ORK SYSTEM ENABLE/DISABLE")
  1.  Q
  1.  ;
  1. SIGINFO(RESULT,VIADFN,VIAPROV) ;returns the provider/patient info that must be displayed when signing controlled substance orders
  1.  ;ICR-#10061,10060,10090,2343
  1.  ;RPC VIAB DEA SIGINFO
  1.  ;This RPC is a similar to ORDEA SIGINFO
  1.  N VIAI S VIAI=0
  1.  ;patient name
  1.  S VIAI=VIAI+1,DFN=VIADFN
  1.  D DEM^VADPT
  1.  S RESULT(VIAI)=VADM(1)
  1.  ;date of issuance
  1.  S VIAI=VIAI+1,RESULT(VIAI)="Date of Issuance: "_$$FMTE^XLFDT($$DT^XLFDT)
  1.  ;provider name
  1.  S VIAI=VIAI+1,RESULT(VIAI)="Provider: "_$$GET1^DIQ(200,VIAPROV,.01,"E")
  1.  ;provider address (facility address)
  1.  N VIAINST
  1.  D GETS^DIQ(4,DUZ(2),".01;.02;1.01;1.02;1.03;1.04","E","VIAINST")
  1.  N VIADDNUM S VIADDNUM=0
  1.  I $L(VIAINST(4,DUZ(2)_",",1.01,"E"))>0 S VIAI=VIAI+1,RESULT(VIAI)=VIAINST(4,DUZ(2)_",",1.01,"E"),VIADDNUM=VIADDNUM+1
  1.  I $L(VIAINST(4,DUZ(2)_",",1.02,"E"))>0 S VIAI=VIAI+1,RESULT(VIAI)=VIAINST(4,DUZ(2)_",",1.02,"E"),VIADDNUM=VIADDNUM+1
  1.  I $L(VIAINST(4,DUZ(2)_",",1.03,"E"))>0 S VIAI=VIAI+1,RESULT(VIAI)=VIAINST(4,DUZ(2)_",",1.03,"E"),VIADDNUM=VIADDNUM+1
  1.  I $L(VIAINST(4,DUZ(2)_",",.02,"E"))>0 S RESULT(VIAI)=RESULT(VIAI)_", "_VIAINST(4,DUZ(2)_",",.02,"E"),VIADDNUM=VIADDNUM+1
  1.  I $L(VIAINST(4,DUZ(2)_",",1.04,"E"))>0 S RESULT(VIAI)=RESULT(VIAI)_"  "_VIAINST(4,DUZ(2)_",",1.04,"E"),VIADDNUM=VIADDNUM+1
  1.  I VIADDNUM=0 D
  1.  .S VIAI=VIAI+1,RESULT(VIAI)="No Address on record"
  1.  .I $L(VIAINST(4,DUZ(2)_",",.01,"E"))>0 S VIAI=VIAI+1,RESULT(VIAI)="for "_VIAINST(4,DUZ(2)_",",.01,"E")
  1.  ;dea #
  1.  S VIAI=VIAI+1,RESULT(VIAI)="DEA: "_$$DEA^XUSER(,VIAPROV)
  1.  ;detox #
  1.  N VIADETOX S VIADETOX=$$DETOX^XUSER(VIAPROV)
  1.  I $L(VIADETOX)>0 S VIAI=VIAI+1,RESULT(VIAI)="Detox: "_VIADETOX
  1.  D KVA^VADPT
  1.  Q
  1.  ;
  1. SCHALL(RESULT,LOCIEN)     ; return all schedules;ICR-#10040,4546
  1.  ;RPC VIAB SCHALL
  1.  ;This RPC is a similar to ORWDPS1 SCHALL
  1.  N CNT,ILST,ORARRAY,WIEN
  1.  S WIEN=$$WARDIEN(+$G(LOCIEN))
  1.  D SCHED^PSS51P1(WIEN,.ORARRAY)
  1.  S ILST=0
  1.  S CNT=0 F  S CNT=$O(ORARRAY(CNT)) Q:CNT'>0  D
  1.  .S ILST=ILST+1,RESULT(ILST)=$P(ORARRAY(CNT),U,2,5)
  1.  Q
  1.  ;
  1. WARDIEN(LOCIEN) ;
  1.  N RESULT
  1.  S RESULT=0
  1.  I LOCIEN=0 Q RESULT
  1.  I $P($G(^SC(LOCIEN,42)),U)="" Q RESULT
  1.  S RESULT=+$P($G(^SC(LOCIEN,42)),U)
  1.  Q RESULT
  1.  ;
  1. VALSCH(RESULT,X,PSTYPE)    ; validate a schedule, return 1 if valid, 0 if not;ICR-#2946
  1.  ;RPC VIAB VALSCH
  1.  ;This RPC is a similar to ORWDPS32 VALSCH
  1.  I '$L($T(EN^PSSGSGUI)) S RESULT=-1 Q
  1.  I $E($T(EN^PSSGSGUI),1,4)="EN(X" D
  1.  . N ORX S ORX=$G(X) D EN^PSSGSGUI(.ORX,$G(PSTYPE,"I"))
  1.  . K X S:$D(ORX) X=ORX
  1.  E  D
  1.  . D EN^PSSGSGUI
  1.  S RESULT=$S($D(X):1,1:0)
  1.  Q
  1.  ;
  1. IMOLOC(RESULT,VIALOC,VIADFN) ;RESULT>=0: VIALOC is an IMO authorized location; ICR-#4133,10040,6347,4422
  1.  ;RPC VIAB IMOLOC
  1.  ;This RPC is a similar to ORIMO IMOLOC
  1.  N A,TYPE
  1.  S RESULT=-1
  1.  K ^TMP($J,"VIAIMO")
  1.  S RESULT=$$SDIMO^SDAMA203(VIALOC,VIADFN)
  1.  ;if RSA returns an error then check against Clinic Loc.
  1.  I RESULT=-3 D
  1.  . S TYPE=$$GET1^DIQ(44,VIALOC,2,"E") I TYPE'="C" Q
  1.  . I $D(^SC("AE",1,VIALOC))=1 S RESULT=1
  1.  K SDIMO(1)
  1.  I $D(^TMP($J,"OR MOB APP1")) K ^("OR MOB APP1") D
  1.  . D ALL^PSJ53P46(+VIALOC,"VIAIMO")
  1.  . S A=$G(^TMP($J,"VIAIMO",0))
  1.  . I A'>0!(+$G(^TMP($J,"VIAIMO",A,3))=0) S RESULT=-1
  1.  K SDIMO
  1.  Q
  1.  ;
  1. ALLSAMP(RESULT) ; procedure;ICR-2389,10055
  1.  ;RPC VIAB ALLSAMP
  1.  ;This RPC is a similar to ORWDLR32 ALLSAMP
  1.  ; returns all collection samples
  1.  ; n^SampIEN^SampName^SpecPtr^TubeTop^^^LabCollect^^SpecName
  1.  N SMP,SPC,ILST,IEN,X,A,%,INC,X2,X3,X7
  1.  S ILST=0,RESULT($$NXT)="~CollSamp"
  1.  S SMP="" F  S SMP=$O(^LAB(62,"B",SMP)) Q:SMP=""  D
  1.  . S IEN=0 F  S IEN=$O(^LAB(62,"B",SMP,IEN)) Q:'IEN  D
  1.  . . S INC=1,A=$$GET1^DIQ(62,IEN,64.9101,"I")
  1.  . . D NOW^%DTC I A]"",A'>$P(%,".") S INC=0 Q
  1.  . . S X2=$$GET1^DIQ(62,IEN,2,"I"),X3=$$GET1^DIQ(62,IEN,3,"I"),X7=$$GET1^DIQ(62,IEN,7,"I")
  1.  . . S X="i"_U_IEN_U_SMP_U_X2_U_X3_U_U_U_X7
  1.  . . I X2 D
  1.  . . . S $P(X,U,10)=$$GET1^DIQ(61,+X2,.01,"I")
  1.  . . . S SPC($P(X,U,4))=$P(X,U,10)
  1.  . . S RESULT($$NXT)=X
  1.  S RESULT($$NXT)="~Specimens"
  1.  S SPC=0 F  S SPC=$O(SPC(SPC)) Q:'SPC  S RESULT($$NXT)=SPC_U_SPC(SPC)
  1.  Q
  1.  ;
  1. NXT() ; increments ILST
  1.  S ILST=ILST+1
  1.  Q ILST
  1.  ;
  1. MAXDAYS(RESULT,LOC,SCHED) ; Return max number of days for a continuing order;ICR -#4546,2263
  1.  ;RPC VIAB MAXDAYS
  1.  ;This RPC is a similar to ORWDLR32 MAXDAYS
  1.  N TMP1,TMP2
  1.  K ^TMP($J,"ORWDLR33 MAXDAYS")
  1.  S TMP1=$$GET^XPAR("ALL^LOC.`"_+LOC,"LR MAX DAYS CONTINUOUS",1,"Q")
  1.  I +TMP1=0 S RESULT="-1" Q
  1.  I +$G(SCHED)>0 D ZERO^PSS51P1(SCHED,,,,"ORWDLR33 MAXDAYS") S TMP2=$G(^TMP($J,"ORWDLR33 MAXDAYS",SCHED,2.5)) K ^TMP($J,"ORWDLR33 MAXDAYS")
  1.  E  S TMP2=0
  1.  I +TMP1=0,+TMP2>0 S RESULT=TMP2 Q
  1.  I +TMP2=0,+TMP1>0 S RESULT=TMP1 Q
  1.  S RESULT=$S(+TMP1>+TMP2:+TMP2,+TMP2>+TMP1:+TMP1,+TMP1=+TMP2:+TMP1,1:0)
  1.  K ^TMP($J,"ORWDLR33 MAXDAYS")
  1.  Q
  1.  ;
  1. INPLOC(RESULT,FROM,DIR) ;Return a set of wards from HOSPITAL LOCATION
  1.  ;RPC VIAB INPLOC
  1.  ;This RPC is a similar to ORWU INPLOC
  1.  ; .RESULT=returned list, FROM=text to $O from, DIR=$O direction,
  1.  N I,IEN,CNT S I=0,CNT=44
  1.  F  Q:I'<CNT  S FROM=$O(^SC("B",FROM),DIR) Q:FROM=""  D  ; IA# 10040.
  1.  . S IEN="" F  S IEN=$O(^SC("B",FROM,IEN),DIR) Q:'IEN  D
  1.  . . I ($P($G(^SC(IEN,0)),U,3)'="W") Q
  1.  . . I '$$ACTLOC(IEN) Q
  1.  . . S I=I+1,RESULT(I)=IEN_"^"_FROM
  1.  Q
  1. ACTLOC(LOC) ; Function: returns TRUE if active hospital location-ICR-#10040,1246
  1.  ; IA# 10040.
  1.  N D0,X I +$G(^SC(LOC,"OOS")) Q 0                ; screen out OOS entry
  1.  S D0=+$G(^SC(LOC,42)) I D0 D WIN^DGPMDDCF Q 'X  ; chk out of svc wards
  1.  S X=$G(^SC(LOC,"I")) I +X=0 Q 1                 ; no inactivate date
  1.  I DT>$P(X,U)&($P(X,U,2)=""!(DT<$P(X,U,2))) Q 0  ; chk reactivate date
  1.  Q 1                                             ; must still be active
  1.  ;