- DVBAREQS ;ALB ISC/THM-SHORT RPT FOR NEW 7131 REQUESTS; 21 JUL 89@0129
- ;;2.7;AMIE;**2,17**;Apr 10, 1995
- ;called by DVBAREQ1 for short version of new requests
- ;
- SETUP S %DT="AE",DIC="^DVB(396,",BDT1=$$FMTE^XLFDT(BDT,"5DZ"),EDT1=$$FMTE^XLFDT(EDT,"5DZ")
- I XDIV'="ALL" S (BDIV,EDIV)=$P(^DG(40.8,XDIV,0),U,1)
- I XDIV="ALL" S BDIV="@",EDIV=""
- ;
- INFO S DHD="VARO 7131 NEW REQUEST REPORT FOR "_BDT1_" TO "_EDT1_" * SHORT VERSION *",L=0,FLDS=".01;L15,1;L12,2;L12,NUMDATE4(#3);L10;""ACT/ADM DATE"",23;L11,29;L9"
- S ^TMP(396,$J,1,2,3,4,5,6)=""
- S DIOBEG="K ^TMP(396,$J) D TMPSET^DVBAREQS(BDT,EDT,XDIV)"
- S (FR(0),TO(0))=""
- S DISPAR(0,2)="^;""DOCUMENT TYPE: "";S2"
- S BY(0)="^TMP(396,$J,",L(0)=6
- S DHIT="I $P($G(^DVB(396,D0,2)),U,9)="""" W ?9,""** REGIONAL OFFICE MUST EDIT THE INCOMPLETE REQUEST LISTED ABOVE **"",!"
- ;
- PRINT D EN1^DIP
- ;
- EXIT K FR,BY,DIS,DHIT,TO,L,FLDS,DHD,^TMP(396,$J),DIOBEG,FR(0),TO(0),BY(0),L(0)
- Q
- ;
- NAME ;this is called from DVBAREQ1 when a selection is made by name.
- S DHD="VARO 7131 NEW REQUEST REPORT FOR "_$P(DA,U,2)_" * SHORT VERSION *",(FR,TO)=+DA,BY="@NUMBER"
- S L=0,DIC="^DVB(396,"
- S FLDS=".01;L15,1;L12,2;L12,NUMDATE4(#3);L10;""ACT/ADM DATE"",23;L11,29;L9"
- D PRINT
- Q
- ;
- VERSION() ;Get whether user wants long or short version
- N DTOUT,DUOUT,Y
- S DIR(0)="SM^L:Long;S:Short",DIR("A")="Select version",DIR("B")="Long"
- D ^DIR
- K DIR
- I $D(DTOUT)!($D(DUOUT)) Q 0
- Q $S(Y="L"!(Y="S"):Y,1:0)
- ;
- KILL1 ;
- K DVBDA,DVBVER,DA,NODTA,QQ,DVBAON2,^TMP($J),VAR
- Q
- ;
- KILL S XRTN=$T(+0)
- D SPM^DVBCUTL4
- I $D(ZTQUEUED)&($D(DVBAMAN)) D KILL^%ZTLOAD
- K DVBAON2,DVBAMAN,^TMP($J),LPDIV,DVBOUT,DVBSEL,VAR,DVBVER,DVBDA,DVBATASK,DVBSTOP
- D KILL^DVBAUTIL
- Q
- ;
- TMPSET(BDT,EDT,XDIV) ;**Set ^TMP X-Ref for short report
- ;** ^TMP("396",$J) array returned and must be KILLed by calling rtn
- N LPDT,LPDIV,LPDA,DOCTYPE,DTOFREQ,DIV,PATNAME,TYPEORD
- F LPDT=((BDT-1)+.2359):0 S LPDT=$O(^DVB(396,"AE",LPDT)) Q:LPDT>EDT!(LPDT="") DO
- .S:XDIV'="ALL" LPDIV=+XDIV-1
- .S:XDIV="ALL" LPDIV=""
- .F S LPDIV=$O(^DVB(396,"AE",LPDT,LPDIV)) Q:(LPDIV=""!(XDIV'="ALL"&(XDIV'=LPDIV))) DO
- ..F LPDA=0:0 S LPDA=$O(^DVB(396,"AE",LPDT,LPDIV,LPDA)) Q:LPDA="" DO
- ...S DOCTYPE=$P($G(^DVB(396,LPDA,2)),U,10)
- ...S TYPEORD=$S(DOCTYPE="A":1,DOCTYPE="L":2,1:3)
- ...S DOCTYPE=$S(DOCTYPE="A":"ADMISSION DATE",DOCTYPE="L":"ACTIVITY DATE",1:"")
- ...S DTOFREQ=$P($G(^DVB(396,LPDA,1)),U,1)
- ...S DIV=$P($G(^DVB(396,LPDA,2)),U,9)
- ...S PATNAME=$P($G(^DVB(396,LPDA,0)),U,1)
- ...S ^TMP("396",$J,TYPEORD,DOCTYPE,DTOFREQ,DIV,PATNAME,LPDA)=""
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBAREQS 2575 printed Feb 18, 2025@23:08:28 Page 2
- DVBAREQS ;ALB ISC/THM-SHORT RPT FOR NEW 7131 REQUESTS; 21 JUL 89@0129
- +1 ;;2.7;AMIE;**2,17**;Apr 10, 1995
- +2 ;called by DVBAREQ1 for short version of new requests
- +3 ;
- SETUP SET %DT="AE"
- SET DIC="^DVB(396,"
- SET BDT1=$$FMTE^XLFDT(BDT,"5DZ")
- SET EDT1=$$FMTE^XLFDT(EDT,"5DZ")
- +1 IF XDIV'="ALL"
- SET (BDIV,EDIV)=$PIECE(^DG(40.8,XDIV,0),U,1)
- +2 IF XDIV="ALL"
- SET BDIV="@"
- SET EDIV=""
- +3 ;
- INFO SET DHD="VARO 7131 NEW REQUEST REPORT FOR "_BDT1_" TO "_EDT1_" * SHORT VERSION *"
- SET L=0
- SET FLDS=".01;L15,1;L12,2;L12,NUMDATE4(#3);L10;""ACT/ADM DATE"",23;L11,29;L9"
- +1 SET ^TMP(396,$JOB,1,2,3,4,5,6)=""
- +2 SET DIOBEG="K ^TMP(396,$J) D TMPSET^DVBAREQS(BDT,EDT,XDIV)"
- +3 SET (FR(0),TO(0))=""
- +4 SET DISPAR(0,2)="^;""DOCUMENT TYPE: "";S2"
- +5 SET BY(0)="^TMP(396,$J,"
- SET L(0)=6
- +6 SET DHIT="I $P($G(^DVB(396,D0,2)),U,9)="""" W ?9,""** REGIONAL OFFICE MUST EDIT THE INCOMPLETE REQUEST LISTED ABOVE **"",!"
- +7 ;
- PRINT DO EN1^DIP
- +1 ;
- EXIT KILL FR,BY,DIS,DHIT,TO,L,FLDS,DHD,^TMP(396,$JOB),DIOBEG,FR(0),TO(0),BY(0),L(0)
- +1 QUIT
- +2 ;
- NAME ;this is called from DVBAREQ1 when a selection is made by name.
- +1 SET DHD="VARO 7131 NEW REQUEST REPORT FOR "_$PIECE(DA,U,2)_" * SHORT VERSION *"
- SET (FR,TO)=+DA
- SET BY="@NUMBER"
- +2 SET L=0
- SET DIC="^DVB(396,"
- +3 SET FLDS=".01;L15,1;L12,2;L12,NUMDATE4(#3);L10;""ACT/ADM DATE"",23;L11,29;L9"
- +4 DO PRINT
- +5 QUIT
- +6 ;
- VERSION() ;Get whether user wants long or short version
- +1 NEW DTOUT,DUOUT,Y
- +2 SET DIR(0)="SM^L:Long;S:Short"
- SET DIR("A")="Select version"
- SET DIR("B")="Long"
- +3 DO ^DIR
- +4 KILL DIR
- +5 IF $DATA(DTOUT)!($DATA(DUOUT))
- QUIT 0
- +6 QUIT $SELECT(Y="L"!(Y="S"):Y,1:0)
- +7 ;
- KILL1 ;
- +1 KILL DVBDA,DVBVER,DA,NODTA,QQ,DVBAON2,^TMP($JOB),VAR
- +2 QUIT
- +3 ;
- KILL SET XRTN=$TEXT(+0)
- +1 DO SPM^DVBCUTL4
- +2 IF $DATA(ZTQUEUED)&($DATA(DVBAMAN))
- DO KILL^%ZTLOAD
- +3 KILL DVBAON2,DVBAMAN,^TMP($JOB),LPDIV,DVBOUT,DVBSEL,VAR,DVBVER,DVBDA,DVBATASK,DVBSTOP
- +4 DO KILL^DVBAUTIL
- +5 QUIT
- +6 ;
- TMPSET(BDT,EDT,XDIV) ;**Set ^TMP X-Ref for short report
- +1 ;** ^TMP("396",$J) array returned and must be KILLed by calling rtn
- +2 NEW LPDT,LPDIV,LPDA,DOCTYPE,DTOFREQ,DIV,PATNAME,TYPEORD
- +3 FOR LPDT=((BDT-1)+.2359):0
- SET LPDT=$ORDER(^DVB(396,"AE",LPDT))
- if LPDT>EDT!(LPDT="")
- QUIT
- Begin DoDot:1
- +4 if XDIV'="ALL"
- SET LPDIV=+XDIV-1
- +5 if XDIV="ALL"
- SET LPDIV=""
- +6 FOR
- SET LPDIV=$ORDER(^DVB(396,"AE",LPDT,LPDIV))
- if (LPDIV=""!(XDIV'="ALL"&(XDIV'=LPDIV)))
- QUIT
- Begin DoDot:2
- +7 FOR LPDA=0:0
- SET LPDA=$ORDER(^DVB(396,"AE",LPDT,LPDIV,LPDA))
- if LPDA=""
- QUIT
- Begin DoDot:3
- +8 SET DOCTYPE=$PIECE($GET(^DVB(396,LPDA,2)),U,10)
- +9 SET TYPEORD=$SELECT(DOCTYPE="A":1,DOCTYPE="L":2,1:3)
- +10 SET DOCTYPE=$SELECT(DOCTYPE="A":"ADMISSION DATE",DOCTYPE="L":"ACTIVITY DATE",1:"")
- +11 SET DTOFREQ=$PIECE($GET(^DVB(396,LPDA,1)),U,1)
- +12 SET DIV=$PIECE($GET(^DVB(396,LPDA,2)),U,9)
- +13 SET PATNAME=$PIECE($GET(^DVB(396,LPDA,0)),U,1)
- +14 SET ^TMP("396",$JOB,TYPEORD,DOCTYPE,DTOFREQ,DIV,PATNAME,LPDA)=""
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +15 QUIT