MCARUTL2 ;HOIFO/WAA-Utility Routine #2;11/29/00 09:55
;;2.3;Medicine;**30**;09/13/1996
;;
;;These APIs are referenced in DBIA 3279
;Input:
; Required:
; ARRAY = Array that data is to be stored in
; DFN = Patient DFN
; SUB = Sub Speciality on file 697.2
; Optional:
; FROM = From date
; TO = To date
;
SUB(ARRAY,DFN,SUB,FROM,TO) ; Set a Screen for certain Speciality
N PATNAM,SPEC,CNT,FLG,PDATE,PEDATE,SUBTXT,FILE,FNAME,FN,IEN,%,I,X
N %I,%H,DISYS
K ARRAY ; Purge Array
S PATNAM="",CNT=0 ; init
I DFN'="" S PATNAM=$$GET1^DIQ(2,DFN_",",.01,"I") ; Get patient name
I PATNAM="" S ARRAY(CNT)="0^No patient has been defined." Q ; no patient name
I '$D(^MCAR(690,DFN,0)) S ARRAY(CNT)="0^"_PATNAM_" has NO Medicine Procedures on file." Q ; Patient is not in Medicine patient
I $G(FROM)="" S FROM=0 ; get from the beginning of time
I $G(TO)="" D NOW^%DTC S TO=% ; get to now
I SUB="" S ARRAY(CNT)="0^No Procedure defined." Q
S SUBTXT=SUB ; if passing Text name saving it
I SUB'?1N.N S SUB=$O(^MCAR(697.2,"B",SUB,0))
I SUB<1 S ARRAY(CNT)="0^"_SUBTXT_"is an invalid Sub Speciality." Q
; ^----Will quit id Sub is not found in the 697.2,"B"
S SPEC=$G(^MCAR(697.2,SUB,0)) ; Getting Sub Spec
I SPEC="" S ARRAY(CNT)="0^"_SUBTXT_"is an invalid Sub Speciality." Q
; ^--- No Sub Spec.
S FILE=$P(SPEC,U,2) ; Extended Reference
S FN=$P(FILE,"(",2) ; file Number in MCAR name Range
S FNAME=$P(SPEC,U) ; Procedure Name
S IEN=0 ; v--- Looping in file FN for Patient DFN
F S IEN=$O(^MCAR(FN,"C",DFN,IEN)) Q:IEN<1 D
. N LIN
. S LIN=$G(^MCAR(FN,IEN,0))
. Q:LIN="" ; Invalid entry
. ;Filter 699 and 699.5 for valid procedures
. I FN=699,$P(LIN,U,12)'=SUB Q
. I FN=699.5,$P(LIN,U,6)'=SUB Q
. ;Filter dates
. S PDATE=$P(LIN,U) ; Procedure date
. I PDATE<FROM Q ; quit out of range
. I PDATE>TO Q ; quit out of range
. S PEDATE=$$FMTE^XLFDT(PDATE,8) ; convert date to external format
. S CNT=CNT+1
. S ARRAY(CNT)=PEDATE_U_FNAME_U_PATNAM_U_FILE_U_IEN
. ; getting Imaging PT
. 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
. . N IEN2005
. . S IEN2005=$P($G(^MCAR(FN,IEN,2005,IMAGE,0)),U) Q:IEN2005<1
. . S CNT2=CNT2+1
. . S ARRAY(CNT,2005,CNT2)=IEN2005
. . Q
. ; ^------ Building Array for entry
. I $D(ARRAY(CNT,2005,1)) S ARRAY(CNT)=ARRAY(CNT)_U_"1"_U
. E S ARRAY(CNT)=ARRAY(CNT)_U_"0"_U
. Q
I CNT<1 S ARRAY(CNT)="0^No "_FNAME_" procedure found for Patient "_PATNAM
; ^------- No entries found for patient
E S ARRAY(0)="1^"_CNT_" "_FNAME_" Procedure"_$S(CNT=1:"",1:"s")_" found for Patient "_PATNAM
; ^------- Processing 0 node on array if data was found
S ARRAY=CNT ; passing total number of entries found for patient
Q
PATLK() ; Lookup patient in medicine file.
N DIC,X,Y,DILN,%,I,%I,DGMT,DGMTE,DGWRT,DISYS,DST,DGNOCOPF
S DIC="^MCAR(690,",DIC(0)="AEMQ"
D ^DIC
Q +Y
PATSUB(ARRAY,DFN) ; Find all Subs for a patient
N PATNAM,SPEC,CNT,FLG,PDATE,PEDATE,IMAGE,SUBTXT,FILE,FNAME,FN,IEN,SUB,DISYS
K ARRAY ; Purge Array
S PATNAM="",CNT=0 ; init
I DFN'="" S PATNAM=$$GET1^DIQ(2,DFN_",",.01,"I") ; Get patient name
I PATNAM="" S ARRAY(CNT)="0^No patient has been defined." Q ; no patient name
I '$D(^MCAR(690,DFN,0)) S ARRAY(CNT)="0^"_PATNAM_" has NO Medicine Procedures on file." Q ; Patient is not in Medicine patient
S SUB=0
F S SUB=$O(^MCAR(697.2,SUB)) Q:SUB<1 D
. ; Go thur all the entries in 697.2
. N LN,IEN,PCNT
. S LN=$G(^MCAR(697.2,SUB,0)) ; insure that the entry is valid
. Q:LN=""
. S FILE=$P(LN,U,2) ; get the MCAR file name
. S FN=$P(FILE,"(",2) ; get the file number
. S FNAME=$P(LN,U) ; get the procedure name
. Q:'$D(^MCAR(FN,"C",DFN)) ; quit if there is no entry for that patient
. S PCNT=$$VALDT(DFN,FN,SUB) I PCNT=0 Q ; Validate that there are SUBs
. S CNT=CNT+1
. S ARRAY(CNT)=FNAME_U_SUB_U_PCNT ; Build array string
. Q
S ARRAY=CNT
I CNT=0 S ARRAY(CNT)="0^There are no Procedures on file for "_PATNAM
E S ARRAY=CNT S ARRAY(0)="1^There were "_CNT_" procedures found for patient "_PATNAM
Q
VALDT(DFN,FN,SUB) ; Validate that there is a report for that patient
N ANS,IEN
S (ANS,IEN)=0 ; Init
F S IEN=$O(^MCAR(FN,"C",DFN,IEN)) Q:IEN<1 D
. ; Loop thru and validate each entry for a subspeciality
. N LIN ; init
. S LIN=$G(^MCAR(FN,IEN,0)) ; check the 0 node valid
. Q:LIN="" ; Invalid entry
. ;Filter 699 and 699.5 for valid procedures
. I FN=699,$P(LIN,U,12)'=SUB Q
. I FN=699.5,$P(LIN,U,6)'=SUB Q
. S ANS=ANS+1 ; If it is valid then add 1 to the count
. Q
Q ANS ; pass back the total number of valid entries found
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCARUTL2 4727 printed Sep 23, 2025@19:50:53 Page 2
MCARUTL2 ;HOIFO/WAA-Utility Routine #2;11/29/00 09:55
+1 ;;2.3;Medicine;**30**;09/13/1996
+2 ;;
+3 ;;These APIs are referenced in DBIA 3279
+4 ;Input:
+5 ; Required:
+6 ; ARRAY = Array that data is to be stored in
+7 ; DFN = Patient DFN
+8 ; SUB = Sub Speciality on file 697.2
+9 ; Optional:
+10 ; FROM = From date
+11 ; TO = To date
+12 ;
SUB(ARRAY,DFN,SUB,FROM,TO) ; Set a Screen for certain Speciality
+1 NEW PATNAM,SPEC,CNT,FLG,PDATE,PEDATE,SUBTXT,FILE,FNAME,FN,IEN,%,I,X
+2 NEW %I,%H,DISYS
+3 ; Purge Array
KILL ARRAY
+4 ; init
SET PATNAM=""
SET CNT=0
+5 ; Get patient name
IF DFN'=""
SET PATNAM=$$GET1^DIQ(2,DFN_",",.01,"I")
+6 ; no patient name
IF PATNAM=""
SET ARRAY(CNT)="0^No patient has been defined."
QUIT
+7 ; Patient is not in Medicine patient
IF '$DATA(^MCAR(690,DFN,0))
SET ARRAY(CNT)="0^"_PATNAM_" has NO Medicine Procedures on file."
QUIT
+8 ; get from the beginning of time
IF $GET(FROM)=""
SET FROM=0
+9 ; get to now
IF $GET(TO)=""
DO NOW^%DTC
SET TO=%
+10 IF SUB=""
SET ARRAY(CNT)="0^No Procedure defined."
QUIT
+11 ; if passing Text name saving it
SET SUBTXT=SUB
+12 IF SUB'?1N.N
SET SUB=$ORDER(^MCAR(697.2,"B",SUB,0))
+13 IF SUB<1
SET ARRAY(CNT)="0^"_SUBTXT_"is an invalid Sub Speciality."
QUIT
+14 ; ^----Will quit id Sub is not found in the 697.2,"B"
+15 ; Getting Sub Spec
SET SPEC=$GET(^MCAR(697.2,SUB,0))
+16 IF SPEC=""
SET ARRAY(CNT)="0^"_SUBTXT_"is an invalid Sub Speciality."
QUIT
+17 ; ^--- No Sub Spec.
+18 ; Extended Reference
SET FILE=$PIECE(SPEC,U,2)
+19 ; file Number in MCAR name Range
SET FN=$PIECE(FILE,"(",2)
+20 ; Procedure Name
SET FNAME=$PIECE(SPEC,U)
+21 ; v--- Looping in file FN for Patient DFN
SET IEN=0
+22 FOR
SET IEN=$ORDER(^MCAR(FN,"C",DFN,IEN))
if IEN<1
QUIT
Begin DoDot:1
+23 NEW LIN
+24 SET LIN=$GET(^MCAR(FN,IEN,0))
+25 ; Invalid entry
if LIN=""
QUIT
+26 ;Filter 699 and 699.5 for valid procedures
+27 IF FN=699
IF $PIECE(LIN,U,12)'=SUB
QUIT
+28 IF FN=699.5
IF $PIECE(LIN,U,6)'=SUB
QUIT
+29 ;Filter dates
+30 ; Procedure date
SET PDATE=$PIECE(LIN,U)
+31 ; quit out of range
IF PDATE<FROM
QUIT
+32 ; quit out of range
IF PDATE>TO
QUIT
+33 ; convert date to external format
SET PEDATE=$$FMTE^XLFDT(PDATE,8)
+34 SET CNT=CNT+1
+35 SET ARRAY(CNT)=PEDATE_U_FNAME_U_PATNAM_U_FILE_U_IEN
+36 ; getting Imaging PT
+37 IF (+$PIECE($GET(^MCAR(FN,IEN,2005,0)),U,3))
NEW CNT2,IMAGE
SET (IMAGE,CNT2)=0
FOR
SET IMAGE=$ORDER(^MCAR(FN,IEN,2005,IMAGE))
if IMAGE<1
QUIT
Begin DoDot:2
+38 NEW IEN2005
+39 SET IEN2005=$PIECE($GET(^MCAR(FN,IEN,2005,IMAGE,0)),U)
if IEN2005<1
QUIT
+40 SET CNT2=CNT2+1
+41 SET ARRAY(CNT,2005,CNT2)=IEN2005
+42 QUIT
End DoDot:2
+43 ; ^------ Building Array for entry
+44 IF $DATA(ARRAY(CNT,2005,1))
SET ARRAY(CNT)=ARRAY(CNT)_U_"1"_U
+45 IF '$TEST
SET ARRAY(CNT)=ARRAY(CNT)_U_"0"_U
+46 QUIT
End DoDot:1
+47 IF CNT<1
SET ARRAY(CNT)="0^No "_FNAME_" procedure found for Patient "_PATNAM
+48 ; ^------- No entries found for patient
+49 IF '$TEST
SET ARRAY(0)="1^"_CNT_" "_FNAME_" Procedure"_$SELECT(CNT=1:"",1:"s")_" found for Patient "_PATNAM
+50 ; ^------- Processing 0 node on array if data was found
+51 ; passing total number of entries found for patient
SET ARRAY=CNT
+52 QUIT
PATLK() ; Lookup patient in medicine file.
+1 NEW DIC,X,Y,DILN,%,I,%I,DGMT,DGMTE,DGWRT,DISYS,DST,DGNOCOPF
+2 SET DIC="^MCAR(690,"
SET DIC(0)="AEMQ"
+3 DO ^DIC
+4 QUIT +Y
PATSUB(ARRAY,DFN) ; Find all Subs for a patient
+1 NEW PATNAM,SPEC,CNT,FLG,PDATE,PEDATE,IMAGE,SUBTXT,FILE,FNAME,FN,IEN,SUB,DISYS
+2 ; Purge Array
KILL ARRAY
+3 ; init
SET PATNAM=""
SET CNT=0
+4 ; Get patient name
IF DFN'=""
SET PATNAM=$$GET1^DIQ(2,DFN_",",.01,"I")
+5 ; no patient name
IF PATNAM=""
SET ARRAY(CNT)="0^No patient has been defined."
QUIT
+6 ; Patient is not in Medicine patient
IF '$DATA(^MCAR(690,DFN,0))
SET ARRAY(CNT)="0^"_PATNAM_" has NO Medicine Procedures on file."
QUIT
+7 SET SUB=0
+8 FOR
SET SUB=$ORDER(^MCAR(697.2,SUB))
if SUB<1
QUIT
Begin DoDot:1
+9 ; Go thur all the entries in 697.2
+10 NEW LN,IEN,PCNT
+11 ; insure that the entry is valid
SET LN=$GET(^MCAR(697.2,SUB,0))
+12 if LN=""
QUIT
+13 ; get the MCAR file name
SET FILE=$PIECE(LN,U,2)
+14 ; get the file number
SET FN=$PIECE(FILE,"(",2)
+15 ; get the procedure name
SET FNAME=$PIECE(LN,U)
+16 ; quit if there is no entry for that patient
if '$DATA(^MCAR(FN,"C",DFN))
QUIT
+17 ; Validate that there are SUBs
SET PCNT=$$VALDT(DFN,FN,SUB)
IF PCNT=0
QUIT
+18 SET CNT=CNT+1
+19 ; Build array string
SET ARRAY(CNT)=FNAME_U_SUB_U_PCNT
+20 QUIT
End DoDot:1
+21 SET ARRAY=CNT
+22 IF CNT=0
SET ARRAY(CNT)="0^There are no Procedures on file for "_PATNAM
+23 IF '$TEST
SET ARRAY=CNT
SET ARRAY(0)="1^There were "_CNT_" procedures found for patient "_PATNAM
+24 QUIT
VALDT(DFN,FN,SUB) ; Validate that there is a report for that patient
+1 NEW ANS,IEN
+2 ; Init
SET (ANS,IEN)=0
+3 FOR
SET IEN=$ORDER(^MCAR(FN,"C",DFN,IEN))
if IEN<1
QUIT
Begin DoDot:1
+4 ; Loop thru and validate each entry for a subspeciality
+5 ; init
NEW LIN
+6 ; check the 0 node valid
SET LIN=$GET(^MCAR(FN,IEN,0))
+7 ; Invalid entry
if LIN=""
QUIT
+8 ;Filter 699 and 699.5 for valid procedures
+9 IF FN=699
IF $PIECE(LIN,U,12)'=SUB
QUIT
+10 IF FN=699.5
IF $PIECE(LIN,U,6)'=SUB
QUIT
+11 ; If it is valid then add 1 to the count
SET ANS=ANS+1
+12 QUIT
End DoDot:1
+13 ; pass back the total number of valid entries found
QUIT ANS
