MBAAMDAL ;OIT-PD/VSL - FILE ACCESS DAL ;02/10/2016
;;1.0;Scheduling Calendar View;**1,7**;Feb 13, 2015;Build 16
;
GETREC(RETURN,IFN,FILE,FLDS,SFILES,INT,EXT,REZ,SD) ;
; Input Variables
; RETURN - RETURN results passed by reference
; IFN - Internal Entry Number to the Files passed in (File 2 or File 44)
; FILE - File #
; FLDS = Array of FLDS
; SFILES - Array of Sub-files
; INT - Internal values returned
; EXT - External values returned
; REZ - Resolve field names instead of those peck numbers
; SD - Date.Time if you only want one appointment in particular
; Date if you want all appointment on a give date
; or nothing if you want all appointments from today forward
;
; Get one record and specified subfiles from a file Called by RPC MBAA APPOINTMENT MAKE, MBAA RPC: MBAA CANCEL APPOINTMENT, MBAA PATIENT PENDING APPT
N STRF,FLD,FLAG,C,SFILE,IFLD,REC,SFLDN,SKIPSF
S STRF=""
S IFLD=""
F S IFLD=$O(FLDS(IFLD)) Q:IFLD="" S STRF=STRF_$S(STRF="":"",1:";")_IFLD
S SFILE=""
;
; want to skip subfile 2.98 so it can be done differently. no need to pull in all appointments for a patient since the beginning of time.
F S SFILE=$O(SFILES(SFILE)) Q:SFILE="" I $G(SFILES(SFILE,"F"))'=2.98 S STRF=STRF_$S(STRF="":"",1:";")_SFILE_"*"
;
S FLD="",FLAG=""
S:$G(INT) FLAG=FLAG_"I" ;Returns Internal values
S:$G(EXT) FLAG=FLAG_"E" ;Returns External values
S:$G(REZ) FLAG=FLAG_"R" ;Resolves field numbers to field names
;
D GETS^DIQ(FILE,IFN,STRF,FLAG,"REC")
;
I $G(SFILES(1900,"F"))=2.98 D GETRECA ; this one we'll treat differently cause it can be huge and want to use a screen
;
F S FLD=$O(REC(FILE,""_IFN_",",FLD)) Q:FLD="" D
. S:FLAG=""!(FLAG="R") RETURN(FLD)=REC(FILE,""_IFN_",",FLD)
. S:FLAG["I" RETURN(FLD)=REC(FILE,""_IFN_",",FLD,"I")
. S:FLAG["E" RETURN(FLD)=$S($L($G(RETURN(FLD)))>0:RETURN(FLD)_U,1:"")_REC(FILE,""_IFN_",",FLD,"E")
;
S SFILE=""
F S SFILE=$O(SFILES(SFILE)) Q:SFILE="" D
. S SFLDN=$S(FLAG["R":SFILES(SFILE,"N"),1:SFILE)
. D GETSREC(.RETURN,.REC,SFILES(SFILE,"F"),SFLDN,FLAG)
K FLAG,FILE,STRF
Q
;
GETSREC(RETURN,REC,SFILE,SFLD,FLAG) ; Get record subfile data Called by RPC MBAA APPOINTMENT MAKE, MBAA RPC: MBAA CANCEL APPOINTMENT, MBAA PATIENT PENDING APPT
N IDX,ID S FLD="",IDX=""
F S IDX=$O(REC(SFILE,IDX)) Q:IDX="" D
. F S FLD=$O(REC(SFILE,IDX,FLD)) Q:FLD="" D
. . S ID=$P(IDX,",",1)
. . S:FLAG=""!(FLAG="R") RETURN(SFLD,ID,FLD)=REC(SFILE,IDX,FLD)
. . S:FLAG["I" RETURN(SFLD,ID,FLD)=REC(SFILE,IDX,FLD,"I")
. . S:FLAG["E" RETURN(SFLD,ID,FLD)=$S($L($G(RETURN(SFLD,ID,FLD)))>0:RETURN(SFLD,ID,FLD)_U,1:"")_REC(SFILE,IDX,FLD,"E")
. . N SI S SI=0
. . F S SI=$O(REC(SFILE,IDX,FLD,SI)) Q:SI=""!(SI="I")!(SI="E") D
. . . S RETURN(SFLD,ID,FLD,SI)=REC(SFILE,IDX,FLD,SI),RETURN(SFLD,ID,FLD)=""
Q
;code below is not being used in the initial release of MBAA. It will be released at a later date in a future release of MBAA
;LSTSCOD(FILE,FIELD,LIST) ;List codes in SET OF CODE fields
; ;FILE = file number
; ;FIELD = field number
; ;LIST = output array:
; ; LIST(#)=code^display_name
; N SET,NODE,CODE,NAME,I,COUNT
; S SET=$$GET1^DID(FILE,FIELD,,"POINTER")
; S COUNT=1
; F I=1:1:$L(SET,";") D
; . S NODE=$P(SET,";",I)
; . S CODE=$P(NODE,":")
; . Q:CODE=""
; . S NAME=$P(NODE,":",2)
; . S LIST(COUNT)=CODE_"^"_NAME
; . S COUNT=COUNT+1
; S LIST(0)=COUNT-1
; Q
;
GETRECA ;MBAA*1*7;will use SCREEN to get only the data that is needed from sub-file 2.98
; The orignal code pulled every appointment the patient ever had by doing one inquiry on the patient file.
; It returned so many that it had to store in a global and then parse the global to return everything > than yesterday
; and then potentially further parse when it gets back to calling routine which may have only wanted one to cancel
; Instead of one DIQ call on the patient, it has been changed to a LIST^DIC call using a SCREEN on the sub-file which gets just what you want.
;
; This was rewritten to get a specific appointment for cancellation (SD would be a date.time in FileMan format)
; Or
; It will give everything on a certain date (SD will be just a date, no time)
; Or
; everything from today forward if no date passed in
;
; Will it ever want past appointments?
;
N ERROR,TARGET,APT,IENS,LP,SCREEN
S SCREEN=$$SCREEN($G(SD))
S IENS=","_IFN_","
D LIST^DIC(2.98,IENS,".001;@","EI",,,,,SCREEN,,"TARGET","ERROR")
;
; returns something like this so loop through it
;TARGET("DILIST",0)="97^*^0^"
;TARGET("DILIST",2,1)=3140826.09
;TARGET("DILIST",2,2)=3140925.1
;TARGET("DILIST",2,3)=3141023.08
;
; Make sure we have a bite
I '$D(TARGET("DILIST",2,1)) Q
;
; Now, loop through that list and get the deets
S LP=0 F S LP=$O(TARGET("DILIST",2,LP)) Q:LP="" D
. S IENS=TARGET("DILIST",2,LP)_","_IFN_","
. K APT ; mant to make sure it's clean going in
. D GETS^DIQ(2.98,IENS,"*",FLAG,"APT") ; might need to revisit the * but maybe not. GETREC above also grabs all fields in a subfile.
. M REC=APT ; save off the appointment it's returning
Q
;
SCREEN(SD) ;
; SCREEN will either be I Y=SD (FileMan format)
; or I $P(Y,".")=SD
; or I Y>(TODAY - 1 second) (FileMan Format)
I $P($G(SD),".",2) Q "I Y="_SD
I $G(SD) Q "I $P(Y,""."")="_SD
Q "I Y>"_$$FMADD^XLFDT(DT,0,0,0,-1)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMBAAMDAL 5398 printed Dec 13, 2024@02:14:56 Page 2
MBAAMDAL ;OIT-PD/VSL - FILE ACCESS DAL ;02/10/2016
+1 ;;1.0;Scheduling Calendar View;**1,7**;Feb 13, 2015;Build 16
+2 ;
GETREC(RETURN,IFN,FILE,FLDS,SFILES,INT,EXT,REZ,SD) ;
+1 ; Input Variables
+2 ; RETURN - RETURN results passed by reference
+3 ; IFN - Internal Entry Number to the Files passed in (File 2 or File 44)
+4 ; FILE - File #
+5 ; FLDS = Array of FLDS
+6 ; SFILES - Array of Sub-files
+7 ; INT - Internal values returned
+8 ; EXT - External values returned
+9 ; REZ - Resolve field names instead of those peck numbers
+10 ; SD - Date.Time if you only want one appointment in particular
+11 ; Date if you want all appointment on a give date
+12 ; or nothing if you want all appointments from today forward
+13 ;
+14 ; Get one record and specified subfiles from a file Called by RPC MBAA APPOINTMENT MAKE, MBAA RPC: MBAA CANCEL APPOINTMENT, MBAA PATIENT PENDING APPT
+15 NEW STRF,FLD,FLAG,C,SFILE,IFLD,REC,SFLDN,SKIPSF
+16 SET STRF=""
+17 SET IFLD=""
+18 FOR
SET IFLD=$ORDER(FLDS(IFLD))
if IFLD=""
QUIT
SET STRF=STRF_$SELECT(STRF="":"",1:";")_IFLD
+19 SET SFILE=""
+20 ;
+21 ; want to skip subfile 2.98 so it can be done differently. no need to pull in all appointments for a patient since the beginning of time.
+22 FOR
SET SFILE=$ORDER(SFILES(SFILE))
if SFILE=""
QUIT
IF $GET(SFILES(SFILE,"F"))'=2.98
SET STRF=STRF_$SELECT(STRF="":"",1:";")_SFILE_"*"
+23 ;
+24 SET FLD=""
SET FLAG=""
+25 ;Returns Internal values
if $GET(INT)
SET FLAG=FLAG_"I"
+26 ;Returns External values
if $GET(EXT)
SET FLAG=FLAG_"E"
+27 ;Resolves field numbers to field names
if $GET(REZ)
SET FLAG=FLAG_"R"
+28 ;
+29 DO GETS^DIQ(FILE,IFN,STRF,FLAG,"REC")
+30 ;
+31 ; this one we'll treat differently cause it can be huge and want to use a screen
IF $GET(SFILES(1900,"F"))=2.98
DO GETRECA
+32 ;
+33 FOR
SET FLD=$ORDER(REC(FILE,""_IFN_",",FLD))
if FLD=""
QUIT
Begin DoDot:1
+34 if FLAG=""!(FLAG="R")
SET RETURN(FLD)=REC(FILE,""_IFN_",",FLD)
+35 if FLAG["I"
SET RETURN(FLD)=REC(FILE,""_IFN_",",FLD,"I")
+36 if FLAG["E"
SET RETURN(FLD)=$SELECT($LENGTH($GET(RETURN(FLD)))>0:RETURN(FLD)_U,1:"")_REC(FILE,""_IFN_",",FLD,"E")
End DoDot:1
+37 ;
+38 SET SFILE=""
+39 FOR
SET SFILE=$ORDER(SFILES(SFILE))
if SFILE=""
QUIT
Begin DoDot:1
+40 SET SFLDN=$SELECT(FLAG["R":SFILES(SFILE,"N"),1:SFILE)
+41 DO GETSREC(.RETURN,.REC,SFILES(SFILE,"F"),SFLDN,FLAG)
End DoDot:1
+42 KILL FLAG,FILE,STRF
+43 QUIT
+44 ;
GETSREC(RETURN,REC,SFILE,SFLD,FLAG) ; Get record subfile data Called by RPC MBAA APPOINTMENT MAKE, MBAA RPC: MBAA CANCEL APPOINTMENT, MBAA PATIENT PENDING APPT
+1 NEW IDX,ID
SET FLD=""
SET IDX=""
+2 FOR
SET IDX=$ORDER(REC(SFILE,IDX))
if IDX=""
QUIT
Begin DoDot:1
+3 FOR
SET FLD=$ORDER(REC(SFILE,IDX,FLD))
if FLD=""
QUIT
Begin DoDot:2
+4 SET ID=$PIECE(IDX,",",1)
+5 if FLAG=""!(FLAG="R")
SET RETURN(SFLD,ID,FLD)=REC(SFILE,IDX,FLD)
+6 if FLAG["I"
SET RETURN(SFLD,ID,FLD)=REC(SFILE,IDX,FLD,"I")
+7 if FLAG["E"
SET RETURN(SFLD,ID,FLD)=$SELECT($LENGTH($GET(RETURN(SFLD,ID,FLD)))>0:RETURN(SFLD,ID,FLD)_U,1:"")_REC(SFILE,IDX,FLD,"E")
+8 NEW SI
SET SI=0
+9 FOR
SET SI=$ORDER(REC(SFILE,IDX,FLD,SI))
if SI=""!(SI="I")!(SI="E")
QUIT
Begin DoDot:3
+10 SET RETURN(SFLD,ID,FLD,SI)=REC(SFILE,IDX,FLD,SI)
SET RETURN(SFLD,ID,FLD)=""
End DoDot:3
End DoDot:2
End DoDot:1
+11 QUIT
+12 ;code below is not being used in the initial release of MBAA. It will be released at a later date in a future release of MBAA
+13 ;LSTSCOD(FILE,FIELD,LIST) ;List codes in SET OF CODE fields
+14 ; ;FILE = file number
+15 ; ;FIELD = field number
+16 ; ;LIST = output array:
+17 ; ; LIST(#)=code^display_name
+18 ; N SET,NODE,CODE,NAME,I,COUNT
+19 ; S SET=$$GET1^DID(FILE,FIELD,,"POINTER")
+20 ; S COUNT=1
+21 ; F I=1:1:$L(SET,";") D
+22 ; . S NODE=$P(SET,";",I)
+23 ; . S CODE=$P(NODE,":")
+24 ; . Q:CODE=""
+25 ; . S NAME=$P(NODE,":",2)
+26 ; . S LIST(COUNT)=CODE_"^"_NAME
+27 ; . S COUNT=COUNT+1
+28 ; S LIST(0)=COUNT-1
+29 ; Q
+30 ;
GETRECA ;MBAA*1*7;will use SCREEN to get only the data that is needed from sub-file 2.98
+1 ; The orignal code pulled every appointment the patient ever had by doing one inquiry on the patient file.
+2 ; It returned so many that it had to store in a global and then parse the global to return everything > than yesterday
+3 ; and then potentially further parse when it gets back to calling routine which may have only wanted one to cancel
+4 ; Instead of one DIQ call on the patient, it has been changed to a LIST^DIC call using a SCREEN on the sub-file which gets just what you want.
+5 ;
+6 ; This was rewritten to get a specific appointment for cancellation (SD would be a date.time in FileMan format)
+7 ; Or
+8 ; It will give everything on a certain date (SD will be just a date, no time)
+9 ; Or
+10 ; everything from today forward if no date passed in
+11 ;
+12 ; Will it ever want past appointments?
+13 ;
+14 NEW ERROR,TARGET,APT,IENS,LP,SCREEN
+15 SET SCREEN=$$SCREEN($GET(SD))
+16 SET IENS=","_IFN_","
+17 DO LIST^DIC(2.98,IENS,".001;@","EI",,,,,SCREEN,,"TARGET","ERROR")
+18 ;
+19 ; returns something like this so loop through it
+20 ;TARGET("DILIST",0)="97^*^0^"
+21 ;TARGET("DILIST",2,1)=3140826.09
+22 ;TARGET("DILIST",2,2)=3140925.1
+23 ;TARGET("DILIST",2,3)=3141023.08
+24 ;
+25 ; Make sure we have a bite
+26 IF '$DATA(TARGET("DILIST",2,1))
QUIT
+27 ;
+28 ; Now, loop through that list and get the deets
+29 SET LP=0
FOR
SET LP=$ORDER(TARGET("DILIST",2,LP))
if LP=""
QUIT
Begin DoDot:1
+30 SET IENS=TARGET("DILIST",2,LP)_","_IFN_","
+31 ; mant to make sure it's clean going in
KILL APT
+32 ; might need to revisit the * but maybe not. GETREC above also grabs all fields in a subfile.
DO GETS^DIQ(2.98,IENS,"*",FLAG,"APT")
+33 ; save off the appointment it's returning
MERGE REC=APT
End DoDot:1
+34 QUIT
+35 ;
SCREEN(SD) ;
+1 ; SCREEN will either be I Y=SD (FileMan format)
+2 ; or I $P(Y,".")=SD
+3 ; or I Y>(TODAY - 1 second) (FileMan Format)
+4 IF $PIECE($GET(SD),".",2)
QUIT "I Y="_SD
+5 IF $GET(SD)
QUIT "I $P(Y,""."")="_SD
+6 QUIT "I Y>"_$$FMADD^XLFDT(DT,0,0,0,-1)
