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