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

MCARUTL2.m

Go to the documentation of this file. 
  1. MCARUTL2 ;HOIFO/WAA-Utility Routine #2;11/29/00  09:55
  1.  ;;2.3;Medicine;**30**;09/13/1996
  1.  ;;
  1.  ;;These APIs are referenced in DBIA 3279
  1.  ;Input:
  1.  ;   Required: 
  1.  ;     ARRAY = Array that data is to be stored in
  1.  ;     DFN = Patient DFN
  1.  ;     SUB = Sub Speciality on file 697.2
  1.  ;   Optional:
  1.  ;     FROM = From date
  1.  ;     TO = To date
  1.  ;
  1. SUB(ARRAY,DFN,SUB,FROM,TO) ; Set a Screen for certain Speciality
  1.  N PATNAM,SPEC,CNT,FLG,PDATE,PEDATE,SUBTXT,FILE,FNAME,FN,IEN,%,I,X
  1.  N %I,%H,DISYS
  1.  K ARRAY ; Purge Array
  1.  S PATNAM="",CNT=0 ; init
  1.  I DFN'="" S PATNAM=$$GET1^DIQ(2,DFN_",",.01,"I") ; Get patient name
  1.  I PATNAM="" S ARRAY(CNT)="0^No patient has been defined." Q  ; no patient name
  1.  I '$D(^MCAR(690,DFN,0)) S ARRAY(CNT)="0^"_PATNAM_" has NO Medicine Procedures on file." Q  ; Patient is not in Medicine patient
  1.  I $G(FROM)="" S FROM=0 ; get from the beginning of time
  1.  I $G(TO)="" D NOW^%DTC S TO=% ; get to now
  1.  I SUB="" S ARRAY(CNT)="0^No Procedure defined." Q
  1.  S SUBTXT=SUB ; if passing Text name saving it
  1.  I SUB'?1N.N S SUB=$O(^MCAR(697.2,"B",SUB,0))
  1.  I SUB<1 S ARRAY(CNT)="0^"_SUBTXT_"is an invalid Sub Speciality." Q
  1.  ; ^----Will quit id Sub is not found in the 697.2,"B"
  1.  S SPEC=$G(^MCAR(697.2,SUB,0)) ; Getting Sub Spec
  1.  I SPEC="" S ARRAY(CNT)="0^"_SUBTXT_"is an invalid Sub Speciality." Q
  1.  ; ^--- No Sub Spec.
  1.  S FILE=$P(SPEC,U,2) ; Extended Reference
  1.  S FN=$P(FILE,"(",2) ; file Number in MCAR name Range
  1.  S FNAME=$P(SPEC,U) ; Procedure Name
  1.  S IEN=0 ; v--- Looping in file FN for Patient DFN
  1.  F  S IEN=$O(^MCAR(FN,"C",DFN,IEN)) Q:IEN<1  D
  1.  . N LIN
  1.  . S LIN=$G(^MCAR(FN,IEN,0))
  1.  . Q:LIN=""  ; Invalid entry
  1.  . ;Filter 699 and 699.5 for valid procedures
  1.  . I FN=699,$P(LIN,U,12)'=SUB Q
  1.  . I FN=699.5,$P(LIN,U,6)'=SUB Q
  1.  . ;Filter dates
  1.  . S PDATE=$P(LIN,U) ; Procedure date 
  1.  . I PDATE<FROM Q  ; quit out of range
  1.  . I PDATE>TO Q  ; quit out of range
  1.  . S PEDATE=$$FMTE^XLFDT(PDATE,8) ; convert date to external format
  1.  . S CNT=CNT+1
  1.  . S ARRAY(CNT)=PEDATE_U_FNAME_U_PATNAM_U_FILE_U_IEN
  1.  . ; getting Imaging PT
  1.  . I (+$P($G(^MCAR(FN,IEN,2005,0)),U,3)) N CNT2,IMAGE S (IMAGE,CNT2)=0 F  S IMAGE=$O(^MCAR(FN,IEN,2005,IMAGE)) Q:IMAGE<1  D
  1.  . . N IEN2005
  1.  . . S IEN2005=$P($G(^MCAR(FN,IEN,2005,IMAGE,0)),U) Q:IEN2005<1
  1.  . . S CNT2=CNT2+1
  1.  . . S ARRAY(CNT,2005,CNT2)=IEN2005
  1.  . . Q
  1.  . ; ^------ Building Array for entry
  1.  . I $D(ARRAY(CNT,2005,1)) S ARRAY(CNT)=ARRAY(CNT)_U_"1"_U
  1.  . E  S ARRAY(CNT)=ARRAY(CNT)_U_"0"_U
  1.  . Q
  1.  I CNT<1 S ARRAY(CNT)="0^No "_FNAME_" procedure found for Patient "_PATNAM
  1.  ; ^------- No entries found for patient
  1.  E  S ARRAY(0)="1^"_CNT_" "_FNAME_" Procedure"_$S(CNT=1:"",1:"s")_" found for Patient "_PATNAM
  1.  ; ^------- Processing 0 node on array if data was found
  1.  S ARRAY=CNT ; passing total number of entries found for patient
  1.  Q
  1. PATLK() ; Lookup patient in medicine file.
  1.  N DIC,X,Y,DILN,%,I,%I,DGMT,DGMTE,DGWRT,DISYS,DST,DGNOCOPF
  1.  S DIC="^MCAR(690,",DIC(0)="AEMQ"
  1.  D ^DIC
  1.  Q +Y
  1. PATSUB(ARRAY,DFN) ; Find all Subs for a patient
  1.  N PATNAM,SPEC,CNT,FLG,PDATE,PEDATE,IMAGE,SUBTXT,FILE,FNAME,FN,IEN,SUB,DISYS
  1.  K ARRAY ; Purge Array
  1.  S PATNAM="",CNT=0 ; init
  1.  I DFN'="" S PATNAM=$$GET1^DIQ(2,DFN_",",.01,"I") ; Get patient name
  1.  I PATNAM="" S ARRAY(CNT)="0^No patient has been defined." Q  ; no patient name
  1.  I '$D(^MCAR(690,DFN,0)) S ARRAY(CNT)="0^"_PATNAM_" has NO Medicine Procedures on file." Q  ; Patient is not in Medicine patient
  1.  S SUB=0
  1.  F  S SUB=$O(^MCAR(697.2,SUB)) Q:SUB<1  D
  1.  . ; Go thur all the entries in 697.2
  1.  . N LN,IEN,PCNT
  1.  . S LN=$G(^MCAR(697.2,SUB,0)) ; insure that the entry is valid
  1.  . Q:LN=""
  1.  . S FILE=$P(LN,U,2) ; get the MCAR file name
  1.  . S FN=$P(FILE,"(",2) ; get the file number
  1.  . S FNAME=$P(LN,U) ; get the procedure name
  1.  . Q:'$D(^MCAR(FN,"C",DFN))  ; quit if there is no entry for that patient
  1.  . S PCNT=$$VALDT(DFN,FN,SUB) I PCNT=0 Q  ; Validate that there are SUBs
  1.  . S CNT=CNT+1
  1.  . S ARRAY(CNT)=FNAME_U_SUB_U_PCNT ; Build array string
  1.  . Q
  1.  S ARRAY=CNT
  1.  I CNT=0 S ARRAY(CNT)="0^There are no Procedures on file for "_PATNAM
  1.  E  S ARRAY=CNT S ARRAY(0)="1^There were "_CNT_" procedures found for patient "_PATNAM
  1.  Q
  1. VALDT(DFN,FN,SUB) ; Validate that there is a report for that patient
  1.  N ANS,IEN
  1.  S (ANS,IEN)=0 ; Init
  1.  F  S IEN=$O(^MCAR(FN,"C",DFN,IEN)) Q:IEN<1  D
  1.  . ; Loop thru and validate each entry for a subspeciality
  1.  . N LIN ; init
  1.  . S LIN=$G(^MCAR(FN,IEN,0)) ; check the 0 node valid
  1.  . Q:LIN=""  ; Invalid entry
  1.  . ;Filter 699 and 699.5 for valid procedures
  1.  . I FN=699,$P(LIN,U,12)'=SUB Q
  1.  . I FN=699.5,$P(LIN,U,6)'=SUB Q
  1.  . S ANS=ANS+1 ; If it is valid then add 1 to the count
  1.  . Q
  1.  Q ANS ; pass back the total number of valid entries found