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

BGP6DPAP.m

Go to the documentation of this file. 
  1. BGP6DPAP ; IHS/CMI/LAB - COMP NATIONAL GPRA FOR PTS W/APPT ;
  1.  ;;16.1;IHS CLINICAL REPORTING;;MAR 22, 2016;Build 170
  1.  ;
  1. EP ;EP - called from option interactive
  1.  D EOJ
  1.  W:$D(IOF) @IOF
  1.  S BGPCTRL=$O(^BGPCTRL("B",2016,0))
  1.  S X=0 F  S X=$O(^BGPCTRL(BGPCTRL,58,X)) Q:X'=+X  W !,^BGPCTRL(BGPCTRL,58,X,0)
  1. PATS ;
  1.  W !,"Enter a patient's HRN or name (HORSECHIEF,JOHN DOE or HORSECHIEF,JOHN)."
  1.  W !,"A template can also be selected by typing a ""["" followed by"
  1.  W !,"the template name."
  1.  W !,"Entering ""[??"" will list your templates."
  1.  K DIR S DIR(0)="E",DIR("A")="PRESS ENTER" D ^DIR K DIR
  1. SELPT ;
  1.  K BGPSPAT
  1.  S BGPSMI=0
  1.  F  D  Q:U[X
  1.  .S DIR(0)="FOU",DIR("A")="Select patient(s)"
  1.  .S DIR("?",1)="     Enter a patient's HRN or name (HORSECHIEF,JOHN DOE or HORSECHIEF,JOHN).",DIR("?",2)=""
  1.  .S DIR("?",3)="     A template can also be selected by typing a ""["" followed by",DIR("?",4)="     the template name."
  1.  .S DIR("?",5)="",DIR("?")="     ""[??"" will list your templates.",DIR("??")="^D LIST^BGP6DPAP"
  1.  .D ^DIR K DIR
  1.  .S:X[U X=U
  1.  .I $E(X)="[" D  Q
  1.  .. S X=$E(X,2,$L(X))
  1.  .. K DIC S DIC=.401,DIC(0)=$S(X="":"AEMQ",1:"EMQ"),DIC("S")="I $P(^(0),U,4)=2!($P(^(0),U,4)=9000001),($P(^(0),U,5)=$G(DUZ))!(DUZ(0)=""@"")" D ^DIC
  1.  .. I Y>0 D
  1.  ... S BGPSPAT=0,Y=+Y F BGPMJ=0:1 S BGPSPAT=$O(^DIBT(Y,1,BGPSPAT)) Q:'BGPSPAT  S BGPSMI=BGPSMI+1,BGPSPAT(BGPSMI)=BGPSPAT
  1.  ... W !,BGPMJ,$S(BGPMJ=1:" entry",1:" entries")," added."
  1.  .K DIC S DIC=9000001,DIC(0)="EQM" D ^DIC
  1.  .I Y>0 S BGPSPAT=+Y,BGPSMI=BGPSMI+1,BGPSPAT(BGPSMI)=BGPSPAT
  1.  W !
  1.  I X=U K BGPSPAT W !,"All selections cancelled!"
  1.  I '$O(BGPSPAT("")) W !,"No patients selected." D EOJ Q
  1. ZIS ;
  1.  S BGPRTYPE=1,BGPYRPTH="",BGPCPPL=1,BGPINDM="G",BGPYGPU=1,BGPALLPT=1,BGPBEN=3
  1.  S BGPHOME=$P($G(^BGPSITE(DUZ(2),0)),U,2)
  1. ENDDATE ;
  1.  W !!
  1.  S X=$O(^BGPCTRL("B",2016,0))
  1.  S Y=^BGPCTRL(X,0)
  1.  S BGPBD=$P(Y,U,8),BGPED=$P(Y,U,9)
  1.  S BGPPBD=$P(Y,U,10),BGPPED=$P(Y,U,11)
  1.  S BGPBBD=$P(Y,U,12),BGPBED=$P(Y,U,13)
  1.  S BGPPER=$P(Y,U,14),BGPQTR=3
  1.  ;S BGPPER=""
  1.  ;K DIR S DIR(0)="DO^::EXP",DIR("A")="Enter End Date of the Report Period",DIR("B")="June 30, 2016"
  1.  ;D ^DIR G:Y<1 SELPT  S BGPUD=Y
  1.  ;K DIR
  1.  ;AI ;gather all gpra measures
  1.  S X=0 F  S X=$O(^BGPINDM("GPRA",1,X)) Q:X'=+X  S BGPIND(X)=""
  1.  ;S BGPPER=3110630
  1.  ;S BGPED=""
  1.  ;I BGPUD=3110630 S BGPBD=3080701,BGPED=BGPUD,BGPPER=$E(BGPED,1,3)_"0000"
  1.  ;I BGPUD'=3110630 S BGPBD=$$FMADD^XLFDT(BGPUD,-364),BGPED=BGPUD,BGPPER=$E(BGPED,1,3)_"0000"
  1.  ;S BGPVDT=3000000
  1.  ;S X=$E(BGPPER,1,3)-$E(BGPVDT,1,3)
  1.  ;S X=X_"0000"
  1.  ;S BGPBBD=BGPBD-X,BGPBBD=$E(BGPBBD,1,3)_$E(BGPBD,4,7)
  1.  ;S BGPBED=BGPED-X,BGPBED=$E(BGPBED,1,3)_$E(BGPED,4,7)
  1.  ;S BGPPBD=($E(BGPBD,1,3)-1)_$E(BGPBD,4,7)
  1.  ;S BGPPED=($E(BGPED,1,3)-1)_$E(BGPED,4,7)
  1.  S BGPLIST="A"
  1.  S BGPCPLC=0
  1.  ;D REPORT^BGP6UTL
  1.  ;I $G(BGPQUIT) D EOJ Q
  1.  ;I BGPRPT="" D EOJ Q
  1.  S XBRP="PRINT^BGP6DPAP",XBRC="PROC^BGP6DPAP",XBRX="EOJ^BGP6DPAP",XBNS="BGP"
  1.  D ^XBDBQUE
  1.  Q
  1. EOJ ;
  1.  D ^XBFMK
  1.  K DIC,DIR,DFN
  1.  D EN^XBVK("BGP"),EN^XBVK("BSD"),EN^XBVK("AMQQ")
  1.  K ^TMP($J)
  1.  Q
  1.  ;
  1. TEST ;
  1.  D BDMG(1,3040101,3041231,13)
  1.  Q
  1. BDMG(BGPBD,BGPED,BGPCLN) ;EP - GUI DMS Entry Point
  1.  ;cmi/anch/maw added 10/19/2004
  1.  S BGPSD=$$FMADD^XLFDT(BGPBD,-1)_".9999"
  1.  S BGPGUI=1
  1.  N BGPOPT,BGPNOW,BGPIEN  ;maw
  1.  S BGPOPT="List Patients on a Register w/an Appointment"
  1.  S BGPRTYPE=1,BGPYRPTH="",BGPCPPL=1,BGPINDM="G",BGPYGPU=1
  1.  D NOW^%DTC
  1.  S BGPNOW=$G(%)
  1.  K DD,D0,DIC
  1.  S X=DUZ_$$NOW^XLFDT
  1.  S DIC("DR")=".02////"_DUZ_";.03////"_BGPNOW_";.06///"_$G(BGPOPT)_";.07////R"
  1.  S DIC="^BGPGUIM(",DIC(0)="L",DIADD=1,DLAYGO=9001004.4
  1.  D FILE^DICN
  1.  K DIADD,DLAYGO,DIC,DA
  1.  I Y=-1 S BGPIEN=-1 Q
  1.  S BGPIEN=+Y
  1.  S BDMGIEN=BGPIEN  ;cmi/maw added
  1.  D ^XBFMK
  1.  K ZTSAVE S ZTSAVE("*")=""
  1.  S ZTIO="",ZTDTH=$$NOW^XLFDT,ZTRTN="GUIEP^BGP6DPA",ZTDESC="GUI CN GRPA APPT" D ^%ZTLOAD
  1.  D EOJ
  1.  Q
  1. GUIEP ;EP
  1.  D PROC
  1.  K ^TMP($J,"BGP6DPAP")
  1.  S IOM=80
  1.  D GUIR^XBLM("PRINT^BGP6DPA","^TMP($J,""BGP6DPAP"",")
  1.  S X=0,C=0 F  S X=$O(^TMP($J,"BGP6DPAP",X)) Q:X'=+X  D
  1.  .S BGPDATA=^TMP($J,"BGP6DPAP",X)
  1.  .I BGPDATA="ZZZZZZZ" S BGPDATA=$C(12)
  1.  .S ^BGPGUIM(BGPIEN,11,X,0)=BGPDATA,C=C+1
  1.  S ^BGPGUIM(BGPIEN,11,0)="^^"_C_"^"_C_"^"_DT_"^"
  1.  S DA=BGPIEN,DIK="^BGPGUIM(" D IX1^DIK
  1.  D ENDLOG
  1.  K ^TMP($J,"BGP6DPAP")
  1.  S ZTREQ="@"
  1.  Q
  1.  ;
  1. ENDLOG ;-- write the end of the log
  1.  D NOW^%DTC
  1.  S BGPNOW=$G(%)
  1.  S DIE="^BGPGUIM(",DA=BGPIEN,DR=".04////"_BGPNOW_";.07////C"
  1.  D ^DIE
  1.  K DIE,DR,DA
  1.  Q
  1.  ;
  1. PROC ;
  1.  D JRNL^BGP6UTL
  1.  S BGPGPRAJ=$J,BGPGPRAH=$H
  1.  ;S BGPCHWC=0
  1.  ;calculate 3 years before end of each time frame
  1.  S BGP3YE=$$FMADD^XLFDT(BGPED,-1096)
  1.  K ^XTMP("BGP6DPAP",BGPGPRAJ,BGPGPRAH)
  1.  S ^XTMP("BGP6DPAP",0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^"_"PTS WITH AN APPT"
  1.  K BGPAPPT,BGPAPPTS
  1.  S BGPSOX=0 F  S BGPSOX=$O(BGPSPAT(BGPSOX)) Q:BGPSOX'=+BGPSOX  D
  1.  .S DFN=BGPSPAT(BGPSOX)
  1.  .S BGPIISO=1,BGPISST="P" D PROCCY^BGP6D1
  1.  .Q
  1.  Q
  1. DONE ;
  1.  K DIR
  1.  I $E(IOST)="C",IO=IO(0) S DIR(0)="EO",DIR("A")="End of report.  PRESS ENTER" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
  1.  ;W:$D(IOF) @IOF
  1.  K BGPTS,BGPS,BGPM,BGPET
  1.  K ^XTMP("BGP6DPAP",BGPGPRAJ,BGPGPRAH)
  1.  Q
  1.  ;
  1. PRINT ;EP - called from xbdbque
  1.  S BGPIOSL=$S($G(BGPGUI):55,1:IOSL)
  1.  K BGPQ S BGPPG=0,BGPNOD=0
  1.  I '$D(^XTMP("BGP6DPAP",BGPGPRAJ,BGPGPRAH,"PATS")) D HEADER S BGPNOD=1 W !!,"NO DATA TO REPORT",! G DONE
  1.  D HEADER
  1.  S BGPNAME=0 F  S BGPNAME=$O(^XTMP("BGP6DPAP",BGPGPRAJ,BGPGPRAH,"PATS",BGPNAME)) Q:BGPNAME=""!($D(BGPQ))  D
  1.  .S DFN=0 F  S DFN=$O(^XTMP("BGP6DPAP",BGPGPRAJ,BGPGPRAH,"PATS",BGPNAME,DFN)) Q:DFN'=+DFN!($D(BGPQ))  D
  1.  ..I $Y>(BGPIOSL-8) D HEADER Q:$D(BGPQ)
  1.  ..W !!,$$HRN^AUPNPAT(DFN,DUZ(2)),?7,$E($P(^DPT(DFN,0),U),1,25),?38,$P(^DPT(DFN,0),U,2),?42,$$DATE^BGP6UTL($P(^DPT(DFN,0),U,3)),?51,$$COMMRES^AUPNPAT(DFN,"E")
  1.  ..S BGPI=0 F  S BGPI=$O(^XTMP("BGP6DPAP",BGPGPRAJ,BGPGPRAH,"PATS",BGPNAME,DFN,BGPI)) Q:BGPI'=+BGPI!($D(BGPQ))  D
  1.  ...I $Y>(IOSL-3) D HEADER Q:$D(BGPQ)
  1.  ...S BGPT=$P(^XTMP("BGP6DPAP",BGPGPRAJ,BGPGPRAH,"PATS",BGPNAME,DFN,BGPI),U)
  1.  ...S BGPT1=$P(^XTMP("BGP6DPAP",BGPGPRAJ,BGPGPRAH,"PATS",BGPNAME,DFN,BGPI),U,4)
  1.  ...S BGPX=$P(^XTMP("BGP6DPAP",BGPGPRAJ,BGPGPRAH,"PATS",BGPNAME,DFN,BGPI),U,2)
  1.  ...S BGPX1=$P(^XTMP("BGP6DPAP",BGPGPRAJ,BGPGPRAH,"PATS",BGPNAME,DFN,BGPI),U,3)
  1.  ...W !?1,BGPT
  1.  ...F X=1:1 S Y=$P(BGPX,"|",X) Q:Y=""  W:X=2 ?1,BGPT1 W ?28,Y,!
  1.  ...F X=1:1 S Y=$P(BGPX1,"|",X) Q:Y=""  W:X'=1 ! W ?28,Y
  1.  ...;W !?28,$P(BGPX,U,3)
  1.  ...;I BGPX1]"" W !?28,BGPX1
  1.  D DONE
  1.  Q
  1.  G:'BGPPG HEADER1
  1.  K DIR I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S BGPQ="" Q
  1. HEADER1 ;
  1.  W:$D(IOF) @IOF S BGPPG=BGPPG+1
  1.  I $G(BGPGUI),BGPPG'=1 W !,"ZZZZZZZ"
  1.  W !?3,$P(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?70,"Page ",BGPPG,!
  1.  W !!,$$CTR("Patient Listing with GPRA Measure Data",80),!
  1.  S X="Report End Date: "_$$FMTE^XLFDT(BGPED)
  1.  W $$CTR(X,80),!
  1.  W !,"HRN",?7,"PATIENT NAME",?38,"Sex",?42,"DOB",?51,"Community"
  1.  W !,$TR($J("",80)," ","-")
  1.  Q
  1. CTR(X,Y) ;EP - Center X in a field Y wide.
  1.  Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
  1.  ;----------
  1. EOP ;EP - End of page.
  1.  Q:$E(IOST)'="C"
  1.  Q:$D(ZTQUEUED)!'(IOT="TRM")!$D(IO("S"))
  1.  K DIR
  1.  K DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
  1.  S DIR("A")="End of report.  Press Enter",DIR(0)="E" D ^DIR
  1.  Q
  1.  ;----------
  1. USR() ;EP - Return name of current user from ^VA(200.
  1.  Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
  1.  ;----------
  1. LOC() ;EP - Return location name from file 4 based on DUZ(2).
  1.  Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
  1.  ;----------
  1. LIST ;"??" help list
  1.  S BGPMK=0,BGPMJ=IOSL-3 F  S BGPMK=$O(BGPSPAT(BGPMK)) Q:'BGPMK  S BGPSPAT=BGPSPAT(BGPMK),X=$P(^AUPNPAT(BGPSPAT,0),U) D  Q:BGPMJ<0  W !,?2,X
  1.  . S BGPMJ=BGPMJ-1 Q:BGPMJ>0  S BGPMJ=IOSL-2
  1.  . K DIR S DIR(0)="E" D ^DIR I 'Y K DIRUT,DUOUT,DTOUT S BGPMJ=-1
  1.  . S X=" " K DIR Q
  1.  K BGPMK
  1.  Q