source: BMXNET_RPMS_dotNET_UTILITIES-BMX/trunk/m/BMXADOFD.m@ 1177

BMXADOFD        ; IHS/CIHA/GIS - RPC CALL FOR EXTENDED FUNCTIONALITY OF BMXNet UTILITIES ;
        ;;2.3;BMX;;Jan 25, 2011
        ; 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 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)    ; EP-RPC-VERIFY ICD CODE BY RETURNING ITS IEN
        I '$L($G(CODE)) Q ""
        N IEN
        S IEN=$O(^ICD9("BA",CODE_" ",0))
        I 'IEN Q ""
        Q IEN
        ;
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