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

DVBHQZ6.m

Go to the documentation of this file.
  1. DVBHQZ6 ;ISC-ALBANY/JLU/PHH/PJH-print message ; 9/26/11 4:31pm
  1. ;;4.0;HINQ;**28,49,57,62**;03/25/92 ;Build 17
  1. 1 W @$S('$D(IOF):"#",IOF="":"#",1:IOF),!!!
  1. 2 D 2^DVBHUTIL
  1. 3 W !!!,?5,"Printout by (M)ultiple patients, (R)equestor, (D)ate/time? Multiple//"
  1. R DVBA:DTIME G:DVBA="^"!('$T) K S:DVBA="" DVBA="M"
  1. S (DVBMM2,DVBMM)=1 D M:"Mm"[DVBA,R:"Rr"[DVBA,D:"Dd"[DVBA
  1. I "MRDmrd"'[DVBA W !!,*7,?10,"Answer with an 'M', 'R', 'D', <RET> for 'M', or '^' to quit." G 3
  1. K K DVBI,R1,DVBLEN,DVBMM2,X,POP,DVBMM1,DVBA,DVBLP,DVB,DVBMM,DVBLP1,DIC,%,DFN,ZTRTN,ZTSAVE,ZTDESC,ZTIO,DVBJIO,POP,Y,ZTSK,DVBDXSC,DVBIXMZ,DVBUSER,R,DVBCS,%DT,DVBTO,DVBFR
  1. K1 K DVBAL,DVBLP2,DVBIO,DVBLP1,DVBLP1,DVB,DVBMM,DVBJIO I '$D(ZTSK) X ^%ZIS("C")
  1. Q
  1. M S DVB="",DIC="^DVB(395.5,",DIC(0)="AEMZQ"
  1. S DIC("S")="I $D(^(""RS"",0))",DIC("A")="Select patient from ""HINQ Suspense file"":"
  1. F DVBLP=1:1 D ^DIC Q:Y'>0 S DVB=DVB_+Y_"^"
  1. K DIC I Y'>0,DVB="" Q
  1. W ! S ZTRTN="M1^DVBHQZ6",ZTSAVE("DVB")=DVB,ZTSAVE("DVBLP")=DVBLP S:$D(DVBMM2) ZTSAVE("DVBMM2")=DVBMM2 S:$D(DVBMM) ZTSAVE("DVBMM")=DVBMM D LD:'$D(DVBMM1) Q:$D(IO("Q"))!(POP)
  1. M1 F DVBLP1=1:1:DVBLP-1 S DFN=$P(DVB,U,DVBLP1),DVBJIO=$S(IO'=IO(0):IO,1:IO(0)) I $D(^DVB(395.5,DFN,0)),($D(^("RS"))) D TEM^DVBHIQR D:'$D(DVBERCS) EN^DVBHIQM,WRT1^DVBHQD1:'$D(DVBMM1) W:$D(DVBMM1) "." Q:X="^"
  1. Q
  1. ;
  1. DT S %DT="TAEP",%DT("A")="From:" D ^%DT Q:Y<0 S DVBFR=Y,%DT("A")="To:" D ^%DT Q:Y<0 I DVBFR>Y W !,*7,*7,"TO date cannot be earlier than FROM date." G DT
  1. S DVBTO=9999999-(Y+.2400),DVBFR=9999999-(DVBFR-.000001) K %DT Q
  1. ;
  1. R S DIC(0)="AQME",DIC=200 D ^DIC Q:Y<0 S DVBAL=+Y
  1. D DT Q:'$D(DVBFR)!('$D(DVBTO))
  1. S ZTSAVE("DVBMM2")=DVBMM2,ZTSAVE("DVBMM")=DVBMM,ZTSAVE("DVBAL")=DVBAL,ZTSAVE("DVBFR")=DVBFR,ZTSAVE("DVBTO")=DVBTO,ZTRTN="R1^DVBHQZ6" D LD Q:$D(IO("Q"))!(POP)
  1. R1 S X="" F DVBLP=DVBTO:0:9999999 S DVBLP=$O(^DVB(395.5,"C",DVBLP)) Q:DVBLP>DVBFR!(X="^")!('DVBLP) F DFN=0:0 S DFN=$O(^DVB(395.5,"C",DVBLP,DFN)) Q:'DFN!(X="^") I $D(^DVB(395.5,"D",DVBAL,DFN,DVBAL)),$D(^DVB(395.5,DFN,0)),$D(^("RS")) D R3
  1. Q
  1. ;
  1. R3 S DVBJIO=$S(IO'=IO(0):IO,1:IO(0)) D TEM^DVBHIQR D:'$D(DVBERCS) EN^DVBHIQM,WRT1^DVBHQD1 Q
  1. ;
  1. D D DT Q:'$D(DVBFR)!('$D(DVBTO))
  1. S ZTSAVE("DVBMM2")=DVBMM2,ZTSAVE("DVBMM")=DVBMM,ZTSAVE("DVBFR")=DVBFR,ZTSAVE("DVBTO")=DVBTO,ZTRTN="D1^DVBHQZ6" D LD Q:$D(IO("Q"))!(POP)
  1. D1 S X="" F DVBLP=DVBTO:0:9999999 S DVBLP=$O(^DVB(395.5,"C",DVBLP)) Q:DVBLP>DVBFR!(X="^")!('DVBLP) F DFN=0:0 S DFN=$O(^DVB(395.5,"C",DVBLP,DFN)) Q:'DFN!(X="^") I $D(^DVB(395.5,DFN,0)),$D(^("RS")) D R3
  1. Q
  1. ;
  1. EM W !!,"Do you wish to create a mail message, to be sent to the requestors" S %=2 D YN^DICN I %=0 W *7,!,"'YES' to create a mail message 'NO' will not" G EM
  1. I %=1 S DVBMM1=1,POP=0 D M W:$D(DVBLP1) !,"Mail Sent."
  1. D K Q
  1. ;
  1. LD S %IS="MQ" D ^%ZIS Q:POP I $D(IO("Q")) S ZTDESC="This is the HINQ Print/Mail option.",ZTIO=ION D ^%ZTLOAD X ^%ZIS("C")
  1. Q
  1. ;
  1. S1 ;
  1. I $D(DVBDX) D LABELS^DVBHS3
  1. F JU=0:0 S JU=$O(DVBDX(JU)) Q:'JU I +DVBDX(JU),DVBDX(JU)'["-" D S2
  1. Q
  1. S2 I ($Y+5)>IOSL,$E(IOST,1,2)="C-" D PAUSE^DVBHS3
  1. I $G(QUIT)=1 Q
  1. W !,$S($P(DVBDX(JU),U,2)="":$P(DVBDX(JU),U),$D(^DIC(31,$P(DVBDX(JU),U,2),0)):$E($P(^(0),U),1,40),1:"")
  1. W ?42,$S($P(DVBDX(JU),U,3)="X0":100,1:+$P(DVBDX(JU),U,3))
  1. W ?50,$P($G(DVBDX(JU)),U,4)
  1. ;DVB*4*54 - format date fields
  1. N DVBF,DVBFF
  1. F DVBF=5,6 S DVBFF=$P($G(DVBDX(JU)),U,DVBF) D
  1. . I $G(DVBFF)?8N D
  1. . . S M=$E(DVBFF,1,2)
  1. . . D MM^DVBHQM11
  1. . . S DVBF(DVBF)=M_" "_$S($E(DVBFF,3,4)]"":$E(DVBFF,3,4),1:" ")_","_$E(DVBFF,5,8)
  1. W ?55,$G(DVBF(5)),?68,$G(DVBF(6))
  1. K QUIT
  1. Q
  1. ;
  1. QB S %=2 W !!,"Would you like a HINQ message printed out " D YN^DICN I %<0!(%=2) Q
  1. I '% W !!,"A YES will result in a HINQ printout queued to the device you select." G QB
  1. W !,"I will queue all messages!"
  1. K IOP S %IS="NMQ",%IS("B")="" D ^%ZIS K %IS I POP W !,"No printout queued!" G EX
  1. S IOP=ION_";"_IOST_$S($D(IO("DOC")):";"_IO("DOC"),1:";"_IOM_";"_IOSL)
  1. I IO=IO(0) W !,"Can not queue to your HOME device." G QB
  1. I IO'=IO(0),'$D(IO("Q")) W !,"I am QUEUEING this report to run now." S IO("Q")=1,ZTDTH=$H
  1. S DVBMM2=1,ZTRTN="M1^DVBHQZ6",ZTIO=IOP,ZTSAVE("DVB")=DVB,ZTSAVE("DVBLP")=DVBLP,ZTSAVE("DVBMM")=DVBMM,ZTSAVE("DVBMM2")=DVBMM2,ZTDESC="This is the HINQ report." K IO("Q") D ^%ZTLOAD
  1. EX S IOP="HOME" D ^%ZIS K DVB,DVBLP,DVBMM,DVBMM2,ZTRTN,ZTIO,ZTSAVE,ZTDESC,IOP Q
  1. ;
  1. ;APIs added for MSDS (DVB*4*62)
  1. ;------------------------------
  1. ;
  1. DISP(DFN) ;Display episodes for [DVBHINQ PAT-HINQ COMP] template
  1. ;
  1. N ARRAY,MORE
  1. ;If no data exists in .3216 nodes display old data
  1. I '$O(^DPT(DFN,.3216,"B",0)) D OLD(DFN,.ARRAY)
  1. ;Otherwise use .3216 multiple
  1. E D NEW(DFN,.ARRAY)
  1. ;
  1. ;Display MSE data
  1. N BOS,COMP,DATA,DISCH,EODATE,IEN,RADATE,SERVN
  1. S CNT=0
  1. F S CNT=$O(ARRAY(CNT)) Q:'CNT D
  1. .S DATA=$G(ARRAY(CNT)) Q:DATA=""
  1. .S DISCH=$P(DATA,U,6) ;Discharge
  1. .S:DISCH]"" DISCH=$P($G(^DIC(25,DISCH,0)),U)
  1. .S BOS=$P(DATA,U,3) ;Branch
  1. .S:BOS]"" BOS=$P($G(^DIC(23,BOS,0)),U)
  1. .S RADATE=$P(DATA,U) ;Entry Date
  1. .S RADATE=$$FMTE^XLFDT(RADATE)
  1. .S EODATE=$P(DATA,U,2) ;Separation Date
  1. .S EODATE=$$FMTE^XLFDT(EODATE)
  1. .S SERVN=$P(DATA,U,5) ;Service Number
  1. .I CNT=1 W !,?1,"Last episode"
  1. .I CNT=2 W !,?1,"NTL episode"
  1. .I CNT=3 W !,?1,"NNTL episode"
  1. .;Note that Service Component is not displayed
  1. .W !,?1,RADATE,?15,EODATE,?34,BOS,?48,DISCH,?62,SERVN
  1. .I CNT=3,$G(MORE) W !,?1,"<more episodes>"
  1. Q
  1. ;
  1. NEW(DFN,ARRAY) ;Check for new MSE format data
  1. N CNT,SDAT
  1. S CNT=0,SDAT="A"
  1. F S SDAT=$O(^DPT(DFN,.3216,"B",SDAT),-1) Q:'SDAT D Q:CNT>2
  1. .S IEN=$O(^DPT(DFN,.3216,"B",SDAT,0)) Q:'IEN
  1. .S DATA=$G(^DPT(DFN,.3216,IEN,0)) Q:DATA=""
  1. .S CNT=CNT+1,ARRAY(CNT)=DATA
  1. .I CNT=3,$O(^DPT(DFN,.3216,"B",SDAT),-1) S MORE=1
  1. Q
  1. ;
  1. OLD(DFN,ARRAY) ;Get old format VistA data
  1. N DGRP,DGRPX,DGRPED,DGRPSD,DGRPBR,DGRPCO,DGRPSN,DGRPDI
  1. S DGRP(.32)=$G(^DPT(DFN,.32)),DGRP(.3291)=$G(^DPT(DFN,.3291))
  1. ;Last service episode (SL)
  1. D EPISODE(1,4,8)
  1. ;Next to last service episode (SNL)
  1. Q:$P(DGRP(.32),"^",19)'="Y" D EPISODE(2,9,13)
  1. ;Prior episode (SNNL)
  1. I $P(DGRP(.32),"^",20)="Y" D EPISODE(3,14,18)
  1. Q
  1. ;
  1. EPISODE(SUB,P1,P2) ;Get old VistA data and save
  1. S DGRPX=$P(DGRP(.32),U,P1,P2),DGRPCO=$P(DGRP(.3291),U,SUB)
  1. S DGRPDI=$P(DGRPX,U),DGRPBR=$P(DGRPX,U,2),DGRPED=$P(DGRPX,U,3)
  1. S DGRPSD=$P(DGRPX,U,4),DGRPSN=$P(DGRPX,U,5)
  1. ;Save in format of new .3216 multiple (no lock flag)
  1. S ARRAY(SUB)=DGRPED_U_DGRPSD_U_DGRPBR_U_DGRPCO_U_DGRPSN_U_DGRPDI_U
  1. Q