source: WorldVistAEHR/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDF1B1A.m@ 1111

IBDF1B1A ;ALB/CJM - ENCOUNTER FORM PRINT (IBDF1B continued - user options for printing- continuation of IBDF1B1); 3/1/93

 ;;3.0;AUTOMATED INFO COLLECTION SYS;**25**;APR 24, 1997

 ;

ENCL ;for every clinic choosen find patient appointments on DATE

 N DFN,CLNCNAME,IBCLINIC,PNAME,TDIGIT,IBAPPT,IBAPTYP,IBX,Y,IBDIV,FIRST4

 S IBCLINIC="" F  S IBCLINIC=$O(^TMP("IBDF",$J,"C",IBCLINIC)) Q:'IBCLINIC  D

 .;

 .;

 .;get the clinic's division

 .S IBDIV=$$DIVISION^IBDF1B5(IBCLINIC) S:IBDIV="" IBDIV="^ "

 .

 .;setup defined for clinic or division? - otherwise there is nothing to print

 .Q:'($D(^SD(409.95,"B",IBCLINIC))!$D(^SD(409.96,"B",+IBDIV)))

 .S IBDIV=$P(IBDIV,"^",2)

 .;

 .;if restart, sorting is by division/clinic, and clinic is in the starting division, make sure the clinic does not precede the starting clinic

 .I IBDIV=IBSTRTDV,((IBSRT=1)!(IBSRT=3)) S CLNCNAME=$P($G(^SC(IBCLINIC,0)),"^") I CLNCNAME'=IBREPRNT,CLNCNAME']IBREPRNT Q

 .;

 .;find the appts

 .S IBAPPT=IBDT F  S IBAPPT=$O(^SC(IBCLINIC,"S",IBAPPT)) Q:$E(IBAPPT,1,7)'=IBDT  D

 ..S IBX=0 F  S IBX=$O(^SC(IBCLINIC,"S",IBAPPT,1,IBX)) Q:IBX=""  D

 ...Q:$P($G(^SC(IBCLINIC,"S",IBAPPT,1,IBX,0)),"^",9)="C"

 ...S DFN=+$G(^SC(IBCLINIC,"S",IBAPPT,1,IBX,0)) Q:$E($P($G(^DPT(DFN,0)),"^",9),1,5)="00000"&($D(IBDFTSTP))  S PNAME=$P($G(^DPT(DFN,0)),"^") Q:PNAME=""

 ...;check the appt status - may be cancelled

 ...S IBAPTYP=$G(^DPT(DFN,"S",IBAPPT,0)) Q:"NT,I,"'[($P(IBAPTYP,"^",2)_",")

 ...; -- check parameter if inpatient and don't print inpatients then quit

 ...I $P(IBAPTYP,"^",2)="I",$P($G(^IBD(357.09,1,0)),"^",5)=0 Q

 ...;

 ...;if only printing add-ons don't print if already printed

 ...I IBADDONS,IBREPRNT="" Q:$$PRINTED(DFN,IBAPPT)

 ...I IBADDONS,IBREPRNT'="" Q:'$$ADDON(DFN,IBAPPT)

 ...;

 ...;case of sort by clinic,patient

 ...;

 ...;**** when the new SAC standards go into effect, increasing the allowable global subscript length, this line should be substituted for the line following it ****

 ...I IBSRT=1 S CLNCNAME=$P($G(^SC(IBCLINIC,0)),"^") Q:CLNCNAME=""  S ^TMP("IBDF",$J,"P",IBDIV,CLNCNAME,IBCLINIC,$E(PNAME,1,15),DFN,+IBAPPT)=""

 ...; old way ;I IBSRT=1 S CLNCNAME=$P($G(^SC(IBCLINIC,0)),"^") Q:CLNCNAME=""  S ^TMP("IBDF",$J,"P",$E(IBDIV,1,20),$E(CLNCNAME,1,10),IBCLINIC,$E(PNAME,1,10),DFN,+IBAPPT)=""

 ...;

 ...;case of sort by terminal digit

 ...I IBSRT=2 D

 ....S TDIGIT=$$TDG(DFN),FIRST4=$E(TDIGIT,1,$L(TDIGIT)-5)

 ....;

 ....;if this is a restart and clinic is in the starting division, make sure the terminal digits (1st 4) do not precede the restart position

 ....I IBDIV=IBSTRTDV,FIRST4'=IBREPRNT,FIRST4<IBREPRNT Q

 ....;

 ....S ^TMP("IBDF",$J,"P",IBDIV,TDIGIT,DFN,+IBAPPT)=IBCLINIC

 ...;

 ...;case of sort by clinic/terminal digits

 ...;

 ...;**** when the new SAC standards go into effect, increasing the allowable global subscript length, this line should be substituted for the line following it ****

 ...I IBSRT=3 S TDIGIT=$$TDG(DFN),CLNCNAME=$P($G(^SC(IBCLINIC,0)),"^") Q:CLNCNAME=""  S ^TMP("IBDF",$J,"P",IBDIV,CLNCNAME,IBCLINIC,TDIGIT,DFN,+IBAPPT)=""

 ...; this is the old way ;I IBSRT=3 S TDIGIT=$$TDG(DFN),CLNCNAME=$P($G(^SC(IBCLINIC,0)),"^") Q:CLNCNAME=""  S ^TMP("IBDF",$J,"P",$E(IBDIV,1,20),$E(CLNCNAME,1,10),IBCLINIC,TDIGIT,DFN,+IBAPPT)=""

 ;

 ;don't need the list of clinics anymore

 K ^TMP("IBDF",$J,"C")

 Q

 ;

TDG(DFN) ;reformat patient's SSN into terminal digit order, then turns it into a cannonic number

 ; returns either 0 or ssn in terminal digit order

 N X,Y,I,SSN

 S SSN=$P($G(^DPT(DFN,0)),"^",9)

 S Y="" F I=1:1 S X=$E(SSN,I) Q:X=""  I X?1N S Y=Y_X

 S Y=$S(Y'?9N:0,1:$E(Y,8,9)_$E(Y,6,7)_$E(Y,4,5)_$E(Y,1,3))

 Q +Y

 ;

PRINTED(DFN,IBAPPT) ;returns 1 if the print manager already printed forms for this appt, 0 otherwise

 Q +$P($G(^DPT(DFN,"S",IBAPPT,0)),"^",21)

ADDON(DFN,IBAPPT) ;returns 1 if the print manager already printed forms for this appt as an add-on, 0 otherwise

 Q +$P($G(^DPT(DFN,"S",IBAPPT,0)),"^",22)

 ;

GETLIST(DFN,IBDT,DIVISION) ;creates a list of the patient's appts on IBDT

 Q:'DFN!'IBDT

 N APPT,NODE,TO

 S TO=IBDT+.999999

 S ^TMP("IBDF",$J,"APPT LIST",DIVISION,DFN)=""

 S APPT=IBDT-.0001 F  S APPT=$O(^DPT(DFN,"S",APPT)) Q:'APPT!(APPT>TO)  D

 .S NODE=$G(^DPT(DFN,"S",APPT,0))

 .Q:"NT,I,"'[($P(NODE,"^",2)_",")

 .Q:$P($G(^SC(+NODE,0)),"^",15)'=DIVISION

 .; -- check parameter

 .;I $P(NODE,"^",2)="I",$P($G(^IBD(357.09,1,0)),"^",5)=0 Q

 .S ^TMP("IBDF",$J,"APPT LIST",DIVISION,DFN,APPT)=+NODE

 Q

MULTIPLE(DFN,APPT) ;determines if patient=DFN has multiple appts on the list and APPT is the earliest

 N APT

 D GETLIST(DFN,APPT,DIVISION)

 S APT=$O(^TMP("IBDF",$J,"APPT LIST",DIVISION,DFN,""))

 ;Q:APT'=APPT 0

 I $O(^TMP("IBDF",$J,"APPT LIST",DIVISION,DFN,APT))

 Q $T

 ;

DIVHAS(IBDIV) ;returns >0 if the division has anything to print, 0 otherwise

 Q:'$G(IBDIV) 0

 Q $L($O(^SD(409.96,"A",IBDIV,"")))

 ;

CLNCHAS(CLINIC) ;returns>0 if the clinic has something to print

 N NODE,SETUP,I,FOUND

 S SETUP=$O(^SD(409.95,"B",CLINIC,0)) Q:'SETUP 0

 S NODE=$G(^SD(409.95,SETUP,0))

 S FOUND=0 F I=2,3,4,6,8,9 I $P(NODE,"^",I) S FOUND=1 Q

 Q:FOUND 1

 Q $L($O(^SD(409.95,"A",CLINIC,"")))