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

IBDF1B1A.m

Go to the documentation of this file. 
  1. IBDF1B1A ;ALB/CJM - ENCOUNTER FORM PRINT (IBDF1B continued - user options for printing- continuation of IBDF1B1); 3/1/93
  1.  ;;3.0;AUTOMATED INFO COLLECTION SYS;**25**;APR 24, 1997
  1.  ;
  1. ENCL ;for every clinic choosen find patient appointments on DATE
  1.  N DFN,CLNCNAME,IBCLINIC,PNAME,TDIGIT,IBAPPT,IBAPTYP,IBX,Y,IBDIV,FIRST4
  1.  S IBCLINIC="" F  S IBCLINIC=$O(^TMP("IBDF",$J,"C",IBCLINIC)) Q:'IBCLINIC  D
  1.  .;
  1.  .;
  1.  .;get the clinic's division
  1.  .S IBDIV=$$DIVISION^IBDF1B5(IBCLINIC) S:IBDIV="" IBDIV="^ "
  1.  .
  1.  .;setup defined for clinic or division? - otherwise there is nothing to print
  1.  .Q:'($D(^SD(409.95,"B",IBCLINIC))!$D(^SD(409.96,"B",+IBDIV)))
  1.  .S IBDIV=$P(IBDIV,"^",2)
  1.  .;
  1.  .;if restart, sorting is by division/clinic, and clinic is in the starting division, make sure the clinic does not precede the starting clinic
  1.  .I IBDIV=IBSTRTDV,((IBSRT=1)!(IBSRT=3)) S CLNCNAME=$P($G(^SC(IBCLINIC,0)),"^") I CLNCNAME'=IBREPRNT,CLNCNAME']IBREPRNT Q
  1.  .;
  1.  .;find the appts
  1.  .S IBAPPT=IBDT F  S IBAPPT=$O(^SC(IBCLINIC,"S",IBAPPT)) Q:$E(IBAPPT,1,7)'=IBDT  D
  1.  ..S IBX=0 F  S IBX=$O(^SC(IBCLINIC,"S",IBAPPT,1,IBX)) Q:IBX=""  D
  1.  ...Q:$P($G(^SC(IBCLINIC,"S",IBAPPT,1,IBX,0)),"^",9)="C"
  1.  ...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=""
  1.  ...;check the appt status - may be cancelled
  1.  ...S IBAPTYP=$G(^DPT(DFN,"S",IBAPPT,0)) Q:"NT,I,"'[($P(IBAPTYP,"^",2)_",")
  1.  ...; -- check parameter if inpatient and don't print inpatients then quit
  1.  ...I $P(IBAPTYP,"^",2)="I",$P($G(^IBD(357.09,1,0)),"^",5)=0 Q
  1.  ...;
  1.  ...;if only printing add-ons don't print if already printed
  1.  ...I IBADDONS,IBREPRNT="" Q:$$PRINTED(DFN,IBAPPT)
  1.  ...I IBADDONS,IBREPRNT'="" Q:'$$ADDON(DFN,IBAPPT)
  1.  ...;
  1.  ...;case of sort by clinic,patient
  1.  ...;
  1.  ...;**** when the new SAC standards go into effect, increasing the allowable global subscript length, this line should be substituted for the line following it ****
  1.  ...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)=""
  1.  ...; 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)=""
  1.  ...;
  1.  ...;case of sort by terminal digit
  1.  ...I IBSRT=2 D
  1.  ....S TDIGIT=$$TDG(DFN),FIRST4=$E(TDIGIT,1,$L(TDIGIT)-5)
  1.  ....;
  1.  ....;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
  1.  ....I IBDIV=IBSTRTDV,FIRST4'=IBREPRNT,FIRST4<IBREPRNT Q
  1.  ....;
  1.  ....S ^TMP("IBDF",$J,"P",IBDIV,TDIGIT,DFN,+IBAPPT)=IBCLINIC
  1.  ...;
  1.  ...;case of sort by clinic/terminal digits
  1.  ...;
  1.  ...;**** when the new SAC standards go into effect, increasing the allowable global subscript length, this line should be substituted for the line following it ****
  1.  ...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)=""
  1.  ...; 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)=""
  1.  ;
  1.  ;don't need the list of clinics anymore
  1.  K ^TMP("IBDF",$J,"C")
  1.  Q
  1.  ;
  1. TDG(DFN) ;reformat patient's SSN into terminal digit order, then turns it into a cannonic number
  1.  ; returns either 0 or ssn in terminal digit order
  1.  N X,Y,I,SSN
  1.  S SSN=$P($G(^DPT(DFN,0)),"^",9)
  1.  S Y="" F I=1:1 S X=$E(SSN,I) Q:X=""  I X?1N S Y=Y_X
  1.  S Y=$S(Y'?9N:0,1:$E(Y,8,9)_$E(Y,6,7)_$E(Y,4,5)_$E(Y,1,3))
  1.  Q +Y
  1.  ;
  1. PRINTED(DFN,IBAPPT) ;returns 1 if the print manager already printed forms for this appt, 0 otherwise
  1.  Q +$P($G(^DPT(DFN,"S",IBAPPT,0)),"^",21)
  1. ADDON(DFN,IBAPPT) ;returns 1 if the print manager already printed forms for this appt as an add-on, 0 otherwise
  1.  Q +$P($G(^DPT(DFN,"S",IBAPPT,0)),"^",22)
  1.  ;
  1. GETLIST(DFN,IBDT,DIVISION) ;creates a list of the patient's appts on IBDT
  1.  Q:'DFN!'IBDT
  1.  N APPT,NODE,TO
  1.  S TO=IBDT+.999999
  1.  S ^TMP("IBDF",$J,"APPT LIST",DIVISION,DFN)=""
  1.  S APPT=IBDT-.0001 F  S APPT=$O(^DPT(DFN,"S",APPT)) Q:'APPT!(APPT>TO)  D
  1.  .S NODE=$G(^DPT(DFN,"S",APPT,0))
  1.  .Q:"NT,I,"'[($P(NODE,"^",2)_",")
  1.  .Q:$P($G(^SC(+NODE,0)),"^",15)'=DIVISION
  1.  .; -- check parameter
  1.  .;I $P(NODE,"^",2)="I",$P($G(^IBD(357.09,1,0)),"^",5)=0 Q
  1.  .S ^TMP("IBDF",$J,"APPT LIST",DIVISION,DFN,APPT)=+NODE
  1.  Q
  1. MULTIPLE(DFN,APPT) ;determines if patient=DFN has multiple appts on the list and APPT is the earliest
  1.  N APT
  1.  D GETLIST(DFN,APPT,DIVISION)
  1.  S APT=$O(^TMP("IBDF",$J,"APPT LIST",DIVISION,DFN,""))
  1.  ;Q:APT'=APPT 0
  1.  I $O(^TMP("IBDF",$J,"APPT LIST",DIVISION,DFN,APT))
  1.  Q $T
  1.  ;
  1. DIVHAS(IBDIV) ;returns >0 if the division has anything to print, 0 otherwise
  1.  Q:'$G(IBDIV) 0
  1.  Q $L($O(^SD(409.96,"A",IBDIV,"")))
  1.  ;
  1. CLNCHAS(CLINIC) ;returns>0 if the clinic has something to print
  1.  N NODE,SETUP,I,FOUND
  1.  S SETUP=$O(^SD(409.95,"B",CLINIC,0)) Q:'SETUP 0
  1.  S NODE=$G(^SD(409.95,SETUP,0))
  1.  S FOUND=0 F I=2,3,4,6,8,9 I $P(NODE,"^",I) S FOUND=1 Q
  1.  Q:FOUND 1
  1.  Q $L($O(^SD(409.95,"A",CLINIC,"")))