IBDF1B5 ;ALB/CJM - ENCOUNTER FORM - (prints reports defined by print manager); 5/15/93
;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
;
PRNTOTHR(CLINIC,APPT,DFN) ;prints reports defined for CLINIC/DIVISION
; -- input CLINIC = ien file 44
; -- APPT = pts appointment date in fm format
; -- DFN = ptr to pt file
Q:'CLINIC!('APPT)!('DFN)
N DIVISION,RPT,IBDIV,IBCLIN
S DIVISION=+$$DIVISION(CLINIC)
; -- build arrays of reports to print
D DIV(DIVISION,.IBDIV),CLIN(CLINIC,.IBCLIN)
; -- go through clinic reports and print
S RPT=0 F S RPT=$O(IBCLIN(RPT)) Q:'RPT I '$$EXCLUDE(CLINIC,RPT) D PRINT(RPT,$P(IBCLIN(RPT),"^",2))
; -- go through division reports
S RPT=0 F S RPT=$O(IBDIV(RPT)) Q:'RPT I '$$EXCLUDE(CLINIC,RPT) D
.N RULE,RNAR
.Q:$D(IBCLIN(RPT)) ; already defined for clinic (clinic overrides div)
.S RULE=+IBDIV(RPT),RNAR=$G(^IBE(357.92,+RULE,0)) ; set rule and narrative
.I RNAR["MULTIPLE",'$$MULTIPLE^IBDF1B1A(DFN,$E(IBAPPT,1,7)) Q ; if rule=print for multiple appts and pt does not have multiple appts that day, quit
.I RNAR["EARLIEST",'$$EARLIEST(DFN,DIVISION,IBAPPT,RPT) Q ;if rule=print for earliest appt that does not exclude, and this is not the earliest appt that includes the rpt, quit
.D PRINT(RPT,$P(IBDIV(RPT),"^",2))
Q
;
DIV(DIVISION,DIV) ; -- builds array of reports to print for division
; -- input DIVISION = ien from 40.8
; -- DIV = name of array to pass back
; -- output array in format DIV(ien of report)=""
N TYPE,RTN,SETUP,RPT
Q:'DIVISION
F TYPE=0:0 S TYPE=$O(^SD(409.96,"A",DIVISION,TYPE)) Q:'TYPE F RTN=0:0 S RTN=$O(^SD(409.96,"A",DIVISION,TYPE,RTN)) Q:'RTN F SETUP=0:0 S SETUP=$O(^SD(409.96,"A",DIVISION,TYPE,RTN,SETUP)) Q:'SETUP D
.S RPT=0 F S RPT=$O(^SD(409.96,"A",DIVISION,TYPE,RTN,SETUP,RPT)) Q:'RPT S DIV(+$G(^SD(409.96,SETUP,1,RPT,0)))=$P($G(^SD(409.96,SETUP,1,RPT,0)),"^",2,3)
Q
;
CLIN(CLINIC,CLIN) ; -- builds array of reports to print for clinic
; -- input CLINIC = ien from 44
; -- CLIN = name of array to pass back
; -- output array in format CLIN(ien of report)=""
N TYPE,RTN,SETUP,RPT
Q:'CLINIC
F TYPE=0:0 S TYPE=$O(^SD(409.95,"A",CLINIC,TYPE)) Q:'TYPE S RTN="" F S RTN=$O(^SD(409.95,"A",CLINIC,TYPE,RTN)) Q:'RTN F SETUP=0:0 S SETUP=$O(^SD(409.95,"A",CLINIC,TYPE,RTN,SETUP)) Q:'SETUP D
.S RPT=0 F S RPT=$O(^SD(409.95,"A",CLINIC,TYPE,RTN,SETUP,RPT)) Q:'RPT S CLIN(+$G(^SD(409.95,SETUP,1,RPT,0)))=$P($G(^SD(409.95,SETUP,1,RPT,0)),"^",2,3)
Q
;
EXCLUDE(CLINIC,RPT) ;deterine if report is excluded for specified clinic
; -- input CLINIC = ien from file 44
; -- RPT = ien of report
; -- output 1 if report is excluded, 0 if not excluded
I 'CLINIC!('RPT) Q 0
;print all the reports defined for the entire division,unless excluded for the clinic
Q $S($D(^SD(409.95,"AE",CLINIC,RPT)):1,1:0)
;
EARLIEST(DFN,DIV,APPT,RPT) ;determine if appt is earliest appt that does
; -- not exclude the report
; -- input DFN = ien file 2
; -- DIV = ien 40.8
; -- APPT = appt we have printed EF for
; -- RPT = ien of report
N PRN,APT
Q:'DFN!('DIV)!('APPT)!('RPT)
K ^TMP("IBDF",$J,"APPT LIST")
D GETLIST^IBDF1B1A(DFN,$E(APPT,1,7),DIV)
S APT=0 F S APT=$O(^TMP("IBDF",$J,"APPT LIST",DIV,DFN,APT)) Q:'APT S CLINIC=^(APT) D Q:$D(PRN)
.Q:$D(^SD(409.95,"AE",CLINIC,RPT))
.I APT=APPT S PRN=1 Q
.S PRN=0
Q $S($D(PRN):PRN,1:1)
;
PRINT(PI,SIDES) ;fetches the package interface record,prints the report
; -- input PI = ien of report
; -- SIDES=0-simplex, 1-duplex long-edge, 2-duplex short-edge
N IBRTN S IBRTN=PI N RTN,RPT
D RTNDSCR^IBDFU1B(.IBRTN) ;get the interface description
Q:IBRTN("ACTION")'=4 ;quit if the interface isn't the type that prints a report
;health summaries always use the same rtn to print
I IBRTN("HSMRY?")=1 Q:'IBRTN("HSMRY") S IBRTN("RTN")="PRNTSMRY^IBDFN5("_IBRTN("HSMRY")_")"
N TYPE,DIVISION,CLINIC,QUIT,CLNCNAME,PNAME,PTYPE,TDIGIT
;go to duplex?
D
.I SIDES=1,IBDEVICE("DUPLEX_LONG")]"" W IBDEVICE("DUPLEX_LONG") Q
.I SIDES=2,IBDEVICE("DUPLEX_SHORT")]"" W IBDEVICE("DUPLEX_SHORT") Q
.I IBDEVICE("SIMPLEX")]"" W IBDEVICE("SIMPLEX") Q
.I $Y W @IOF
.I SIDES=0,IBDEVICE("SIMPLEX")]"" W IBDEVICE("SIMPLEX")
N A S A=$$DORTN^IBDFU1B(.IBRTN)
;go back to simplex
D
.I SIDES=1,IBDEVICE("DUPLEX_LONG")]"",IBDEVICE("SIMPLEX")]"" W IBDEVICE("SIMPLEX") Q
.I SIDES=2,IBDEVICE("DUPLEX_SHORT")]"",IBDEVICE("SIMPLEX")]"" W IBDEVICE("SIMPLEX") Q
Q
DIVISION(CLINIC) ;returns the clinic's division - format is IEN^division's name
N DIV,NAME
Q:'$G(CLINIC) ""
S DIV=+$P($G(^SC(CLINIC,0)),"^",15)
I DIV S NAME=$P($G(^DG(40.8,DIV,0)),"^")
I $L($G(NAME)) S DIV=DIV_"^"_NAME
E S DIV=""
Q DIV
IFOTHR(CLINIC,TYPE) ; -- returns a 1 if there are reports defined for CLINIC for print condition=TYPE,0 if otherwise
N RTN,DIVISION,COUNT
S COUNT=0
S TYPE=$O(^IBE(357.92,"B",TYPE,"")) Q:'TYPE 0 ;get ien of TYPE
S DIVISION=+$$DIVISION(CLINIC)
;counts all the reports defined for the entire division
I DIVISION S RTN="" F S RTN=$O(^SD(409.96,"A",DIVISION,TYPE,RTN)) Q:'RTN S:'$D(^SD(409.95,"AE",CLINIC,RTN)) COUNT=COUNT+1 Q:COUNT
;counts all the reports defined for the clinic
S RTN="" F S RTN=$O(^SD(409.95,"A",CLINIC,TYPE,RTN)) Q:'RTN S COUNT=COUNT+1 Q:COUNT
Q COUNT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDF1B5 5352 printed Apr 09, 2024@21:48:19 Page 2
IBDF1B5 ;ALB/CJM - ENCOUNTER FORM - (prints reports defined by print manager); 5/15/93
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
+2 ;
PRNTOTHR(CLINIC,APPT,DFN) ;prints reports defined for CLINIC/DIVISION
+1 ; -- input CLINIC = ien file 44
+2 ; -- APPT = pts appointment date in fm format
+3 ; -- DFN = ptr to pt file
+4 if 'CLINIC!('APPT)!('DFN)
QUIT
+5 NEW DIVISION,RPT,IBDIV,IBCLIN
+6 SET DIVISION=+$$DIVISION(CLINIC)
+7 ; -- build arrays of reports to print
+8 DO DIV(DIVISION,.IBDIV)
DO CLIN(CLINIC,.IBCLIN)
+9 ; -- go through clinic reports and print
+10 SET RPT=0
FOR
SET RPT=$ORDER(IBCLIN(RPT))
if 'RPT
QUIT
IF '$$EXCLUDE(CLINIC,RPT)
DO PRINT(RPT,$PIECE(IBCLIN(RPT),"^",2))
+11 ; -- go through division reports
+12 SET RPT=0
FOR
SET RPT=$ORDER(IBDIV(RPT))
if 'RPT
QUIT
IF '$$EXCLUDE(CLINIC,RPT)
Begin DoDot:1
+13 NEW RULE,RNAR
+14 ; already defined for clinic (clinic overrides div)
if $DATA(IBCLIN(RPT))
QUIT
+15 ; set rule and narrative
SET RULE=+IBDIV(RPT)
SET RNAR=$GET(^IBE(357.92,+RULE,0))
+16 ; if rule=print for multiple appts and pt does not have multiple appts that day, quit
IF RNAR["MULTIPLE"
IF '$$MULTIPLE^IBDF1B1A(DFN,$EXTRACT(IBAPPT,1,7))
QUIT
+17 ;if rule=print for earliest appt that does not exclude, and this is not the earliest appt that includes the rpt, quit
IF RNAR["EARLIEST"
IF '$$EARLIEST(DFN,DIVISION,IBAPPT,RPT)
QUIT
+18 DO PRINT(RPT,$PIECE(IBDIV(RPT),"^",2))
End DoDot:1
+19 QUIT
+20 ;
DIV(DIVISION,DIV) ; -- builds array of reports to print for division
+1 ; -- input DIVISION = ien from 40.8
+2 ; -- DIV = name of array to pass back
+3 ; -- output array in format DIV(ien of report)=""
+4 NEW TYPE,RTN,SETUP,RPT
+5 if 'DIVISION
QUIT
+6 FOR TYPE=0:0
SET TYPE=$ORDER(^SD(409.96,"A",DIVISION,TYPE))
if 'TYPE
QUIT
FOR RTN=0:0
SET RTN=$ORDER(^SD(409.96,"A",DIVISION,TYPE,RTN))
if 'RTN
QUIT
FOR SETUP=0:0
SET SETUP=$ORDER(^SD(409.96,"A",DIVISION,TYPE,RTN,SETUP))
if 'SETUP
QUIT
Begin DoDot:1
+7 SET RPT=0
FOR
SET RPT=$ORDER(^SD(409.96,"A",DIVISION,TYPE,RTN,SETUP,RPT))
if 'RPT
QUIT
SET DIV(+$GET(^SD(409.96,SETUP,1,RPT,0)))=$PIECE($GET(^SD(409.96,SETUP,1,RPT,0)),"^",2,3)
End DoDot:1
+8 QUIT
+9 ;
CLIN(CLINIC,CLIN) ; -- builds array of reports to print for clinic
+1 ; -- input CLINIC = ien from 44
+2 ; -- CLIN = name of array to pass back
+3 ; -- output array in format CLIN(ien of report)=""
+4 NEW TYPE,RTN,SETUP,RPT
+5 if 'CLINIC
QUIT
+6 FOR TYPE=0:0
SET TYPE=$ORDER(^SD(409.95,"A",CLINIC,TYPE))
if 'TYPE
QUIT
SET RTN=""
FOR
SET RTN=$ORDER(^SD(409.95,"A",CLINIC,TYPE,RTN))
if 'RTN
QUIT
FOR SETUP=0:0
SET SETUP=$ORDER(^SD(409.95,"A",CLINIC,TYPE,RTN,SETUP))
if 'SETUP
QUIT
Begin DoDot:1
+7 SET RPT=0
FOR
SET RPT=$ORDER(^SD(409.95,"A",CLINIC,TYPE,RTN,SETUP,RPT))
if 'RPT
QUIT
SET CLIN(+$GET(^SD(409.95,SETUP,1,RPT,0)))=$PIECE($GET(^SD(409.95,SETUP,1,RPT,0)),"^",2,3)
End DoDot:1
+8 QUIT
+9 ;
EXCLUDE(CLINIC,RPT) ;deterine if report is excluded for specified clinic
+1 ; -- input CLINIC = ien from file 44
+2 ; -- RPT = ien of report
+3 ; -- output 1 if report is excluded, 0 if not excluded
+4 IF 'CLINIC!('RPT)
QUIT 0
+5 ;print all the reports defined for the entire division,unless excluded for the clinic
+6 QUIT $SELECT($DATA(^SD(409.95,"AE",CLINIC,RPT)):1,1:0)
+7 ;
EARLIEST(DFN,DIV,APPT,RPT) ;determine if appt is earliest appt that does
+1 ; -- not exclude the report
+2 ; -- input DFN = ien file 2
+3 ; -- DIV = ien 40.8
+4 ; -- APPT = appt we have printed EF for
+5 ; -- RPT = ien of report
+6 NEW PRN,APT
+7 if 'DFN!('DIV)!('APPT)!('RPT)
QUIT
+8 KILL ^TMP("IBDF",$JOB,"APPT LIST")
+9 DO GETLIST^IBDF1B1A(DFN,$EXTRACT(APPT,1,7),DIV)
+10 SET APT=0
FOR
SET APT=$ORDER(^TMP("IBDF",$JOB,"APPT LIST",DIV,DFN,APT))
if 'APT
QUIT
SET CLINIC=^(APT)
Begin DoDot:1
+11 if $DATA(^SD(409.95,"AE",CLINIC,RPT))
QUIT
+12 IF APT=APPT
SET PRN=1
QUIT
+13 SET PRN=0
End DoDot:1
if $DATA(PRN)
QUIT
+14 QUIT $SELECT($DATA(PRN):PRN,1:1)
+15 ;
PRINT(PI,SIDES) ;fetches the package interface record,prints the report
+1 ; -- input PI = ien of report
+2 ; -- SIDES=0-simplex, 1-duplex long-edge, 2-duplex short-edge
+3 NEW IBRTN
SET IBRTN=PI
NEW RTN,RPT
+4 ;get the interface description
DO RTNDSCR^IBDFU1B(.IBRTN)
+5 ;quit if the interface isn't the type that prints a report
if IBRTN("ACTION")'=4
QUIT
+6 ;health summaries always use the same rtn to print
+7 IF IBRTN("HSMRY?")=1
if 'IBRTN("HSMRY")
QUIT
SET IBRTN("RTN")="PRNTSMRY^IBDFN5("_IBRTN("HSMRY")_")"
+8 NEW TYPE,DIVISION,CLINIC,QUIT,CLNCNAME,PNAME,PTYPE,TDIGIT
+9 ;go to duplex?
+10 Begin DoDot:1
+11 IF SIDES=1
IF IBDEVICE("DUPLEX_LONG")]""
WRITE IBDEVICE("DUPLEX_LONG")
QUIT
+12 IF SIDES=2
IF IBDEVICE("DUPLEX_SHORT")]""
WRITE IBDEVICE("DUPLEX_SHORT")
QUIT
+13 IF IBDEVICE("SIMPLEX")]""
WRITE IBDEVICE("SIMPLEX")
QUIT
+14 IF $Y
WRITE @IOF
+15 IF SIDES=0
IF IBDEVICE("SIMPLEX")]""
WRITE IBDEVICE("SIMPLEX")
End DoDot:1
+16 NEW A
SET A=$$DORTN^IBDFU1B(.IBRTN)
+17 ;go back to simplex
+18 Begin DoDot:1
+19 IF SIDES=1
IF IBDEVICE("DUPLEX_LONG")]""
IF IBDEVICE("SIMPLEX")]""
WRITE IBDEVICE("SIMPLEX")
QUIT
+20 IF SIDES=2
IF IBDEVICE("DUPLEX_SHORT")]""
IF IBDEVICE("SIMPLEX")]""
WRITE IBDEVICE("SIMPLEX")
QUIT
End DoDot:1
+21 QUIT
DIVISION(CLINIC) ;returns the clinic's division - format is IEN^division's name
+1 NEW DIV,NAME
+2 if '$GET(CLINIC)
QUIT ""
+3 SET DIV=+$PIECE($GET(^SC(CLINIC,0)),"^",15)
+4 IF DIV
SET NAME=$PIECE($GET(^DG(40.8,DIV,0)),"^")
+5 IF $LENGTH($GET(NAME))
SET DIV=DIV_"^"_NAME
+6 IF '$TEST
SET DIV=""
+7 QUIT DIV
IFOTHR(CLINIC,TYPE) ; -- returns a 1 if there are reports defined for CLINIC for print condition=TYPE,0 if otherwise
+1 NEW RTN,DIVISION,COUNT
+2 SET COUNT=0
+3 ;get ien of TYPE
SET TYPE=$ORDER(^IBE(357.92,"B",TYPE,""))
if 'TYPE
QUIT 0
+4 SET DIVISION=+$$DIVISION(CLINIC)
+5 ;counts all the reports defined for the entire division
+6 IF DIVISION
SET RTN=""
FOR
SET RTN=$ORDER(^SD(409.96,"A",DIVISION,TYPE,RTN))
if 'RTN
QUIT
if '$DATA(^SD(409.95,"AE",CLINIC,RTN))
SET COUNT=COUNT+1
if COUNT
QUIT
+7 ;counts all the reports defined for the clinic
+8 SET RTN=""
FOR
SET RTN=$ORDER(^SD(409.95,"A",CLINIC,TYPE,RTN))
if 'RTN
QUIT
SET COUNT=COUNT+1
if COUNT
QUIT
+9 QUIT COUNT
