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

BMXADOFD.m

Go to the documentation of this file. 
  1. BMXADOFD ; IHS/CIHA/GIS - RPC CALL FOR EXTENDED FUNCTIONALITY OF BMXNet UTILITIES ; 31 Jul 2009  12:41 PM
  1.  ;;4.0;BMX;**4**;JUN 28, 2010;Build 4
  1.  ; THIS IS THE ADO RECORDSET FILER: ADO -> FILEMAN
  1.  ; CONTAINS SPECIAL ENTRY POINT FOR RPMS DATA ENTRY
  1.  ; 
  1.  ; 
  1.  ;
  1.  ; D SS^BMXADO(.XXX,53,"","~~~~~VMEAS~BMXADOFD~1.244A||PU\60|WT\175|HT\70") Q
  1.  ; D SS^BMXADO(.XXX,58,"X","AC~53~53~~~NOTES~BMXADOFD~53") Q
  1.  N FILE,DAS,DATA,XXX S FILE=9000010.07,DAS="+"
  1.  S DATA=".01|`8718"_$C(30)_".02|`1"_$C(30)_".03|`71168"_$C(30)_".04|DM--2"_$C(30,31)
  1.  D FILE^BMXADOF(.XXX,FILE,DAS,DATA) Q
  1.  ; 
  1. VMEAS(DATA,IENS,MAX,OUT,TOT) ; VIEW MEASUREMENTS: CUSTOM ITERATOR
  1.  ; DATA=VCN|ALL|MTYPE1\VAL1|MTYPE2\VAL2|...|MTYPEn\VALn
  1.  N VAL,CNT,P,S,PTIEN,VIEN,%,X,Y,TYPE,N,ALL,STG,MEAS,MIEN,IX
  1.  S P="|",S="\",N=0
  1.  I '$G(TOT) Q ""
  1.  I '$L(OUT) Q ""
  1.  S VIEN=$P(DATA,P) I '$L(VCN) Q ""
  1.  S PTIEN=$P($G(^AUPNVSIT(VIEN,0)),U,5) I 'PTIEN Q ""
  1.  F CNT=2:1 S X=$P(DATA,P,CNT) Q:'$L(X)  D  ; CREATE PRELIMINARY DATA ARRAYS
  1.  . S VAL=$P(X,S,2) ; VALUE MUST EXIST
  1.  . I '$L(VAL) Q
  1.  . S TYPE=$P(X,S) ; TYPE MUST EXIST
  1.  . I '$L(TYPE) Q
  1.  . S MIEN=$O(^AUTTMSR("B",TYPE,0)) I 'MIEN Q
  1.  . S MEAS=$P($G(^AUTTMSR(MIEN,0)),U,2) I '$L(MEAS) Q
  1.  . S N=N+1
  1.  . S VAL(N)=VAL
  1.  . S TYPE(N)=MIEN_U_TYPE_U_MEAS
  1.  . S IX(MIEN)=N
  1.  . Q
  1. MG S N=0 F  S N=$O(VAL(N)) Q:'N  D
  1.  . S TOT=TOT+1
  1.  . S @OUT@(TOT)=+TYPE(N)_U_$P(TYPE(N),U,2)_U_"`"_PTIEN_U_"`"_VIEN_U_VAL(N)_U_$P(TYPE(N),U,3)_$C(30)
  1.  . Q
  1.  Q ""
  1.  ;
  1. ICDVAL(CODE,CHKDT) ; EP-RPC-VERIFY ICD CODE BY RETURNING ITS IEN
  1.  ;
  1.  ;Return File 80 IEN corresponding to input code
  1.  ;If CHKDT populated, return null if code is not valid on that date
  1.  ;
  1.  I '$L($G(CODE)) Q ""
  1.  ;
  1.  NEW STR
  1.  S CHKDT=$G(CHKDT)
  1.  S STR=""
  1.  ;
  1.  ;If no date, always return code
  1.  I CHKDT="" D  Q STR
  1.  . NEW ICDDATA
  1.  . S ICDDATA=$$ICDDX^ICDEX(CODE)
  1.  . S STR=$P(ICDDATA,"^") S:+STR<0 STR=""
  1.  ;
  1.  ;If optional CHKDT is entered, perform
  1.  ;date validity check on code
  1.  ;
  1.  ;Check for ICD-10 implementation date - Use ICD-9 before date
  1.  I $$IMP^ICDEXA(30)>CHKDT D  Q STR
  1.  . S STR=$$ICDDATA^ICDXCODE(1,CODE,CHKDT,"E")
  1.  . S STR=$P(STR,"^") S:+STR<0 STR=""
  1.  ;
  1.  ;Date has passed - Use ICD-10
  1.  S STR=$$ICDDATA^ICDXCODE(30,CODE,DT,"E")
  1.  S STR=$P(STR,"^") S:+STR<0 STR=""
  1.  ;
  1.  Q STR
  1.  ;
  1. FACNIEN(PIEN,FIEN) ;EP - GIVEN A PROBLEM IEN AND FACILITY IEN, RETURN THE FACILITY-NOTE IEN
  1.  I '$D(^AUPNPROB(+$G(PIEN),0)) Q ""
  1.  I '$D(^DIC(4,+$G(FIEN),0)) Q ""
  1.  N NFIEN
  1.  S FNIEN=$O(^AUPNPROB(PIEN,11,"B",FIEN,0)) I FNIEN Q FNIEN ; IF AN FNIEN EXISTS RETURN IT
  1.  ; OTHERWISE-CREATE THE FM STUB NODES FOR THE FACILITY SUBFILE
  1.  S FNIEN=$O(^AUPNPROB(PIEN,11,999999),-1)+1
  1.  S ^AUPNPROB(PIEN,11,FNIEN,0)=FIEN
  1.  S ^AUPNPROB(PIEN,11,FNIEN,11,0)="^9000011.1111IA^^"
  1.  S ^AUPNPROB(PIEN,11,"B",FIEN,FNIEN)=""
  1.  Q FNIEN
  1.  ;
  1. NEXTPBN(DFN,FIEN) ; RETURN THE NEXT AVAILABLE PROBLEM NUMBER FOR A PATIENT AT THE FACILITY
  1.  N MAX,PIEN,X,Y
  1.  S MAX=0,PIEN=0
  1.  F  S PIEN=$O(^AUPNPROB("AC",DFN,PIEN)) Q:'PIEN  D  ; FIND ALL PROBLEMS FOR THIS PATIENT
  1.  . S X=$G(^AUPNPROB(PIEN,0)) I '$L(X) Q
  1.  . I $P(X,U,6)'=FIEN Q  ; ONLY CHECK NUMBERS AT THIS FACILITY
  1.  . S Y=$P(X,U,7)
  1.  . I Y>MAX S MAX=Y ; GET THE HIGHEST NUMBER THUS FAR
  1.  . Q
  1.  S MAX=(MAX\1)+1 ; GET NEXT AVAILABLE INTEGER
  1.  Q MAX
  1.  ;
  1. NN W $$NEXTNOTE(221,4585) Q
  1. NEXTNOTE(PIEN,FIEN) ; RETRUN THE NEXT NOTE NUMBER FOR A PROBLEM AND FACILITY
  1.  I '$D(^AUPNPROB(+$G(PIEN),0)) Q ""
  1.  I '$D(^DIC(4,+$G(FIEN),0)) Q ""
  1.  N MAX,NIEN,FNIEN,X,Y
  1.  S MAX=0,NIEN=0
  1.  S FNIEN=$$FACNIEN^BMXADOFD(PIEN,FIEN) I 'FNIEN Q ""
  1.  F  S NIEN=$O(^AUPNPROB(PIEN,11,FNIEN,11,NIEN)) Q:'NIEN  D
  1.  . S X=$G(^AUPNPROB(PIEN,11,FNIEN,11,NIEN,0)) I '$L(X) Q
  1.  . S Y=+X
  1.  . I Y>MAX S MAX=Y
  1.  . Q
  1.  S MAX=MAX+1
  1.  Q MAX