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

AGEMARP.m

Go to the documentation of this file. 
  1. AGEMARP ; VNGT/IHS/DLS - Patient Email Listing ; May 14, 2010
  1.  ;;7.1;PATIENT REGISTRATION;**8,9**;AUG 25, 2005
  1.  ;
  1. VAR N TYPE,DL,SDL,AGIO
  1.  K ^TMP("AGEMARP",$J)
  1.  ;
  1.  ; Initialize Variables
  1.  ; 
  1.  S DL="^"
  1.  S SDL=","
  1.     ;
  1.  D GETPARMS
  1.  I $G(TYPE("DATE"))="" G EXIT
  1.  I $G(TYPE("DATE","FROM"))="" G EXIT
  1.  I $G(TYPE("DATE","TO"))="" G EXIT
  1.  I $G(TYPE("FORMAT"))="" G EXIT
  1. DEV ;
  1.  S %ZIS="QA"
  1.  D ^%ZIS
  1.  I POP N IOP S IOP=ION D ^%ZIS Q
  1.  I $G(IO("Q")) D QUE D HOME^%ZIS Q
  1.  U IO
  1.  D GO
  1.  D ^%ZISC
  1.  D HOME^%ZIS
  1.  Q
  1. GO ; Start Processing
  1.  D GETDATA
  1.  D PRINT
  1.  G EXIT
  1.  ;
  1.  Q
  1.  ;
  1. GETPARMS ; Get Report Parameters
  1.  N X,Y,DIR
  1.  S DIR("A")="     Select PARAMETER"
  1.  S DIR("B")="L"
  1.  S DIR(0)="SO^L:LAST UPDATE;A:APPOINTMENT DATE"
  1.  S DIR("L",1)="           Choose from:"
  1.  S DIR("L",2)="          L      LAST UPDATE"
  1.  S DIR("L",3)="          A      APPOINTMENT DATE"
  1.  S DIR("L",4)=""
  1.  D ^DIR
  1.  I X["^" Q
  1.  ; Get Output type
  1.  S TYPE("DATE")=X D GETDTS
  1.  I $G(TYPE("DATE","FROM"))="" Q
  1.  I $G(TYPE("DATE","TO"))="" Q
  1.  N DIR
  1.  S DIR("A")="    Select Output Format"
  1.  S DIR("B")="S"
  1.  S DIR(0)="SO^S:STANDARD;F:FLAT FILE"
  1.  S DIR("L",1)="          S      STANDARD"
  1.  S DIR("L",2)="          F      FLAT (Datafile)"
  1.  S DIR("L",3)=""
  1.  D ^DIR
  1.  I Y["^" Q
  1.  S TYPE("FORMAT")=X
  1.  W !
  1.  Q
  1.  ;
  1. GETDTS ; Get Date Range
  1.  D START I $G(TYPE("DATE","FROM"))="" Q
  1.  D END I $G(TYPE("DATE","TO"))="" Q
  1.  Q
  1. START ; Get Start Date
  1.  N X,Y,DIR
  1.  S DIR("A")="     Select START DATE"
  1.  S DIR("B")="T"
  1.  S DIR(0)="DO"
  1.  W !
  1.  D ^DIR
  1.  I Y["^" Q
  1.  I TYPE("DATE")="L",Y>DT D  G START
  1.  . W !!,?11,"Date cannot be in the future.",!
  1.  S TYPE("DATE","FROM")=Y D DD^%DT S $P(TYPE("DATE","FROM"),U,2)=Y W "     ",Y
  1.  Q
  1.  ;
  1. END ; Get end date
  1.  N X,Y,DIR
  1.  S DIR("A")="     Select END DATE"
  1.  S DIR("B")="T"
  1.  S DIR(0)="DO"
  1.  W !
  1.  D ^DIR
  1.  I Y["^" Q
  1.  I TYPE("DATE","FROM")>Y D  G END
  1.  . W !!,?11,"End date cannot be before start date.",!
  1.  I TYPE("DATE")="L",Y>DT D  G END
  1.  . W !!,?11,"Date cannot be in the future.",!
  1.  S TYPE("DATE","TO")=Y D DD^%DT S $P(TYPE("DATE","TO"),U,2)=Y W "     ",Y
  1.  Q
  1.  ;
  1. GETDATA ; Gather Report data
  1.  N TOTCNT,AIANCNT,PATNT,Y,EXTDT
  1.  S (TOTCNT,AIANCNT)=0
  1.  S Y=DT D DD^%DT S EXTDT=Y
  1.  S ^TMP("AGEMARP",$J,0)=$$GET1^DIQ(4,DUZ(2),.01)_DL_EXTDT_DL_$S($G(TYPE("DATE"))="L":"Last Update",1:"Appointment Date")_DL_$P($G(TYPE("DATE","FROM")),U,2)_DL_$P($G(TYPE("DATE","TO")),U,2)
  1.  S PATNT=""
  1.  F  S PATNT=$O(^AUPNPAT("B",PATNT)) Q:+PATNT=0  D
  1.  . N PTNTNM,PTNTEM,CHRTNO,ACCESS,PERMIT,OK,ACCIEN1,ACCIEN2,ACCESS,ACCCNT
  1.  . S PTNTEM=$$GET1^DIQ(9000001,PATNT,1802)
  1.  . Q:PTNTEM=""
  1.  . S OK=0
  1.  . D DTCHK(PATNT,.OK)
  1.  . I OK D
  1.  . . S CHRTNO=$P($G(^AUPNPAT(PATNT,41,DUZ(2),0)),U,2)
  1.  . . S PTNTNM=$$GET1^DIQ(2,PATNT,.01)
  1.  . . S ACCIEN1=0,ACCESS=""
  1.  . . S ACCCNT=$P($G(^AUPNPAT(PATNT,81,0)),U,3)
  1.  . . I ACCCNT]"" F  S ACCIEN1=$O(^AUPNPAT(PATNT,81,ACCCNT,1,ACCIEN1)) Q:+ACCIEN1=0  D
  1.  . . . S ACCIEN2=ACCIEN1_","_ACCCNT_","_PATNT
  1.  . . . S ACCESS=ACCESS_$$GET1^DIQ(9000001.811,ACCIEN2,.01)_SDL
  1.  . . I $E(ACCESS,$L(ACCESS))=SDL S ACCESS=$E(ACCESS,1,($L(ACCESS)-1))
  1.  . . S PERMIT=$$GET1^DIQ(9000001,PATNT,4001)
  1.  . . I $$GET1^DIQ(9000001,PATNT,1111,"I")=1 S AIANCNT=AIANCNT+1
  1.  . . S TOTCNT=TOTCNT+1
  1.  . . S ^TMP("AGEMARP",$J,PTNTNM,PATNT)=CHRTNO_DL_PTNTEM_DL_ACCESS_DL_PERMIT
  1.  S ^TMP("AGEMARP",$J,0)=^TMP("AGEMARP",$J,0)_DL_TOTCNT_"-Total"_DL_AIANCNT_"-Total AI/AN"
  1.  Q
  1.  ;
  1. DTCHK(PATNT,OK) ; Check Date Parameters
  1.  S OK=0
  1.  N VIEN,STDT,ENDT,VDT
  1.  S STDT=+TYPE("DATE","FROM")-1
  1.  S ENDT=+TYPE("DATE","TO")+1
  1.  I TYPE("DATE")="A" D
  1.  . S VIEN=0
  1.  . F  S VIEN=$O(^AUPNVSIT("AC",PATNT,VIEN)) Q:(VIEN="")!(OK)  D
  1.  . . S VDT=$P($G(^AUPNVSIT(VIEN,0)),U)\1
  1.  . . I VDT>STDT,VDT<ENDT S OK=1
  1.  . . Q:OK
  1.  I TYPE("DATE")="L" D
  1.  . N UDT
  1.  . S UDT=$$GET1^DIQ(9000001,PATNT,.03,"I")
  1.  . I UDT>STDT,UDT<ENDT S OK=1
  1.  . Q
  1.  Q
  1.  ;
  1. PRINT ; Top level print engine
  1.  I $O(^TMP("AGEMARP",$J,0))="" W !!,"     No Records Found!" H 3 Q
  1.  I TYPE("FORMAT")="S" D PRINTS
  1.  I TYPE("FORMAT")="F" D PRINTF
  1.  Q
  1. PRINTS ; Generate Standard Output
  1.  N REC,LINECNT,ESCAPE,RECOUT,HRNOUT,EMAOUT,WHROUT,PRMOUT,PAGE,TYP,POP,ESCAPE,AGTOT,AGT,PATNT
  1.  S PAGE=0,ESCAPE=0
  1.  S TYP=$S(TYPE("DATE")="A":" APPTS ",1:" UPDATES ")
  1.  I $G(AGIO)="" U IO
  1.  N AGLINE
  1.  S $P(AGLINE("EQ"),"=",80)=""
  1.  S $P(AGLINE("DASH"),"-",80)=""
  1.  D HDR
  1.  S REC=0
  1.  F  S REC=$O(^TMP("AGEMARP",$J,REC)) Q:(REC="")!(ESCAPE)  D
  1.  . S PATNT=0
  1.  . F  S PATNT=$O(^TMP("AGEMARP",$J,REC,PATNT)) Q:(PATNT="")!(ESCAPE)  D
  1.  . . N WHERCNT
  1.  . . S RECOUT=^TMP("AGEMARP",$J,REC,PATNT)
  1.  . . S HRNOUT=$P(RECOUT,DL)
  1.  . . S EMAOUT=$P(RECOUT,DL,2)
  1.  . . S WHROUT=$P(RECOUT,DL,3)
  1.  . . S PRMOUT=$P(RECOUT,DL,4)
  1.  . . W !,HRNOUT,?9,$E(REC,1,20),?30,EMAOUT
  1.  . . I $L(EMAOUT)>24 W !
  1.  . . W ?55,$E($P(WHROUT,","),1,19),?74," ",PRMOUT
  1.  . . I WHROUT'="" D
  1.  . . . S AGT=$E($P(WHROUT,","),1,19)
  1.  . . . S AGTOT(AGT)=$G(AGTOT(AGT))+1
  1.  . . . S AGTOT("TOTAL")=$G(AGTOT("TOTAL"))+1
  1.  . . I $L(WHROUT,SDL)>1 D
  1.  . . . S WHERCNT=$L(WHROUT,SDL)
  1.  . . . N I F I=2:1:WHERCNT D
  1.  . . . . W !,?55,$P(WHROUT,SDL,I)
  1.  . . . . S AGT=$P(WHROUT,SDL,I)
  1.  . . . . S AGTOT(AGT)=$G(AGTOT(AGT))+1
  1.  . . . . S AGTOT("TOTAL")=$G(AGTOT("TOTAL"))+1
  1.  . . I $O(^TMP("AGEMARP",$J,REC,PATNT))'="" W !,AGLINE("DASH")
  1.  . . I $E(IOST)="C",$Y>(IOSL-5) K DIR D RTRN^AG S ESCAPE=X=U D:'ESCAPE HDR
  1.  . . I $E(IOST)'="C",$Y>(IOSL-17) W !! D HDR
  1.  I 'ESCAPE D
  1.  . W !,AGLINE("EQ")
  1.  . S AGT=""
  1.  . W !!,"TOTALS",!,"----------------"
  1.  . F  S AGT=$O(AGTOT(AGT)) Q:AGT=""  D
  1.  . . I AGT'="TOTAL" D
  1.  . . . W !,AGT
  1.  . . . I AGT="TRIBE/COMMUNITY CEN" W "TER"
  1.  . . . W ?22
  1.  . . . W $J($G(AGTOT(AGT)),10)
  1.  . W !,"================================="
  1.  . W !,$J($G(AGTOT("TOTAL")),32),!!
  1.  I $E(IOST)="C",REC="" K DIR D RTRN^AG
  1.  I $E(IOST)'="C" D CLOSE^%ZISH(IO)
  1.  Q
  1.  ;XU
  1. HDR ; Print Header
  1.  S PAGE=PAGE+1
  1.  W @IOF
  1.  W !,$$GET1^DIQ(200,DUZ,.01)
  1.  W ?(80-$L($$GET1^DIQ(4,DUZ(2),.01)))/2,$$GET1^DIQ(4,DUZ(2),.01)
  1.  W ?70,"Page ",PAGE
  1.  W !,?33,"EMAIL LISTING"
  1.  I TYPE("DATE")="L" W !,?19,"LAST UPDATE: "
  1.  I TYPE("DATE")="A" W !,?16,"APPOINTMENT DATE: "
  1.  I +TYPE("DATE","FROM")=2010101,+TYPE("DATE","TO")=3991231 W "FOR ALL APPOINTMENTS"
  1.  I +TYPE("DATE","FROM")=2010101,+TYPE("DATE","TO")'=3991231 W "FOR ALL",TYP,"THROUGH ",$P(TYPE("DATE","TO"),U,2)
  1.  I +TYPE("DATE","FROM")'=2010101,+TYPE("DATE","TO")=3991231 W "FOR ALL",TYP,"FROM ",$P(TYPE("DATE","FROM"),U,2)
  1.  I +TYPE("DATE","FROM")'=2010101,+TYPE("DATE","TO")'=3991231 D
  1.  . W $P(TYPE("DATE","FROM"),U,2)
  1.  . W " - "
  1.  . W $P(TYPE("DATE","TO"),U,2)
  1.  W !!,"HRN",?9,"NAME",?30,"EMAIL ADDRESS",?55,"WHERE",?69,"PERMISSION"
  1.  W !,AGLINE("EQ")
  1.  Q
  1.  ;
  1. PRINTF ; Generate "Flat" Datafile Output
  1.  N REC,RECOUT,POP,OUTFNM,PATH,FILENAME,PNLNGTH,LPCNT,ESCAPE,I,PATNT
  1.  I $G(AQGIO)="" U IO
  1.  I $E(IOST)="C" W @IOF
  1.  S REC=0,ESCAPE=0
  1.  W ^TMP("AGEMARP",$J,REC)
  1.  F  S REC=$O(^TMP("AGEMARP",$J,REC)) Q:REC=""!ESCAPE  D
  1.  . S PATNT=0
  1.  . F  S PATNT=$O(^TMP("AGEMARP",$J,REC,PATNT)) Q:PATNT=""  D
  1.  . . S RECOUT=REC_DL_^TMP("AGEMARP",$J,REC,PATNT)
  1.  . . W !,RECOUT
  1.  . . I $E(IOST)="C",$Y>(IOSL-5) K DIR D RTRN^AG S ESCAPE=X=U W @IOF
  1.  I $E(IOST)="C",REC="" K DIR D RTRN^AG
  1.  I $E(IOST)'="C" W ! D CLOSE^%ZISH(IO)
  1.  S IOSL=24
  1.  Q
  1.  ;
  1. QUE ;QUE TO TASKMAN
  1.  K IO("Q")
  1.  S ZTRTN="GO^AGEMARP",ZTDESC="Patient Email Address Listing "
  1.  S ZTSAVE("*")=""
  1.  K ZTSK D ^%ZTLOAD
  1.  I $D(ZTSK)[0 W !!?5,"Report Cancelled!"
  1.  E  W !!?5,"Task # ",ZTSK," queued.",!
  1.  H 3
  1.  Q
  1.  ;
  1. EXIT ; Exit the program
  1.  K ^TMP("AGEMARP",$J)
  1.  Q
  1.  ;