- XPDDP ;SFISC/RSD - Display a package ;03/18/2008
- ;;8.0;KERNEL;**21,28,44,68,100,108,229,304,346,463,488,525**;Jul 10, 1995;Build 16
- ; Per VHA Directive 2004-038, this routine should not be modified.
- ; Options: XPD PRINT BUILD calls EN1
- ; XPD PRINT INSTALL calls EN2
- EN1 ; Print from Build file
- N DIC,D0,XPD,XPDT,XPDST,Y
- S XPDST=$$LOOK^XPDB1 Q:XPDST'>0
- S XPD("XPDT(")=""
- D EN^XUTMDEVQ("LST1^XPDDP","Build File Print",.XPD)
- Q
- ;
- EN2 ; Print from Distribution
- N D0,DIC,DIR,DUOUT,DTOUT,POP,XPD,XPDA,XPDNM,XPDP,XPDT,XPDST,Y,Z,%ZIS
- S XPDST=$$LOOK^XPDI1("I $D(^XTMP(""XPDI"",Y))",1) Q:XPDST'>0
- S DIR(0)="SO^1:Print Summary;2:Print Summary and Routines;3:Print Routines",DIR("A")="What to Print"
- D ^DIR Q:Y=""!$D(DTOUT)!$D(DUOUT)
- S XPDP=Y,D0=$O(^XTMP("XPDI",XPDST,"BLD",0)) Q:'D0
- S (XPD("XPDT("),XPD("XPDP"))=""
- D EN^XUTMDEVQ("LST2^XPDDP","Transport Global Print",.XPD)
- Q
- ;
- LST1 ; Print from Build file
- N DIRUT,XPDIT,XPDCNT
- S (XPDIT,XPDCNT)=0
- F S XPDIT=$O(XPDT(XPDIT)) Q:$D(DIRUT)!(XPDIT'>0) D Q:$D(DIRUT)
- . I XPDCNT Q:'$$CONT
- . S XPDCNT=XPDCNT+1
- . S D0=+XPDT(XPDIT) D PNT^XPDDP1("XPD(9.6,D0)")
- D WAIT
- Q
- ;
- LST2 ; Print from XPDT array
- N DIRUT,XPDIT,XPDCNT
- S (XPDIT,XPDCNT)=0
- F S XPDIT=$O(XPDT(XPDIT)) Q:$D(DIRUT)!(XPDIT'>0) D Q:$D(DIRUT)
- . I XPDCNT Q:'$$CONT
- . S XPDCNT=XPDCNT+1,XPDA=+XPDT(XPDIT),D0=$O(^XTMP("XPDI",XPDA,"BLD",0))
- . D PNT^XPDDP1("XTMP(""XPDI"",XPDA,""BLD"",D0)"):XPDP<3,RTN:XPDP>1
- D WAIT
- Q
- ;
- XMP2(X,D0) ;called from ^XMP2
- N XPDA S XPDA=-1
- D PNT^XPDDP1(X)
- Q
- ;
- WAIT ; Pause on last page or not? It depends on whether there's enough room
- ; left on the page to display the KIDS menu.
- Q:$E($G(IOST),1,2)'="C-"
- Q:$D(DIRUT)
- ; DUZ("AUTO")=1 means show menu option choices
- I IOSL-$Y<$S($G(DUZ("AUTO")):14,1:3) D WAIT^XMXUTIL
- Q
- ;
- CONT() ; Press Return to continue; ^ to exit.
- Q:$D(DIRUT) 0
- Q:$E(IOST,1,2)'="C-" 1
- N DIR,I,J,K,X,Y
- S DIR(0)="E" D ^DIR
- Q Y
- ;
- CHK(Y) ;Y=excess lines, return 1 to exit
- ;return 0 to continue
- Q:$Y<(IOSL-Y) 0
- Q:'$$CONT 1
- W @IOF
- Q 0
- ;
- RTN ;Print Routines
- Q:$D(DIRUT)!$$CHK(2)
- N XPD0,XPDI,XPDRTN
- S XPD0=$G(^XTMP("XPDI",XPDA,"BLD",D0,0)) Q:XPD0=""
- I XPDP=3 N XPDDT,XPDPG,XPDUL D
- . S XPDDT=$$HTE^XLFDT($H,"1PM"),XPDPG=1,$P(XPDUL,"-",IOM)=""
- . D HDR^XPDDP1
- . W !,XPDUL
- S XPDRTN=""
- F S XPDRTN=$O(^XTMP("XPDI",XPDA,"RTN",XPDRTN)) Q:XPDRTN="" D Q:$D(DIRUT)
- . W !,XPDRTN S XPDI=0
- . F S XPDI=$O(^XTMP("XPDI",XPDA,"RTN",XPDRTN,XPDI)) Q:'XPDI W !,$G(^(XPDI,0)) Q:$$CHK(2)
- . W ! Q:'$$CHK(2)
- W !! S DIRUT=1
- Q
- XPDDP ;SFISC/RSD - Display a package ;03/18/2008
- +1 ;;8.0;KERNEL;**21,28,44,68,100,108,229,304,346,463,488,525**;Jul 10, 1995;Build 16
- +2 ; Per VHA Directive 2004-038, this routine should not be modified.
- +3 ; Options: XPD PRINT BUILD calls EN1
- +4 ; XPD PRINT INSTALL calls EN2
- EN1 ; Print from Build file
- +1 NEW DIC,D0,XPD,XPDT,XPDST,Y
- +2 SET XPDST=$$LOOK^XPDB1
- IF XPDST'>0
- QUIT
- +3 SET XPD("XPDT(")=""
- +4 DO EN^XUTMDEVQ("LST1^XPDDP","Build File Print",.XPD)
- +5 QUIT
- +6 ;
- EN2 ; Print from Distribution
- +1 NEW D0,DIC,DIR,DUOUT,DTOUT,POP,XPD,XPDA,XPDNM,XPDP,XPDT,XPDST,Y,Z,%ZIS
- +2 SET XPDST=$$LOOK^XPDI1("I $D(^XTMP(""XPDI"",Y))",1)
- IF XPDST'>0
- QUIT
- +3 SET DIR(0)="SO^1:Print Summary;2:Print Summary and Routines;3:Print Routines"
- SET DIR("A")="What to Print"
- +4 DO ^DIR
- IF Y=""!$DATA(DTOUT)!$DATA(DUOUT)
- QUIT
- +5 SET XPDP=Y
- SET D0=$ORDER(^XTMP("XPDI",XPDST,"BLD",0))
- IF 'D0
- QUIT
- +6 SET (XPD("XPDT("),XPD("XPDP"))=""
- +7 DO EN^XUTMDEVQ("LST2^XPDDP","Transport Global Print",.XPD)
- +8 QUIT
- +9 ;
- LST1 ; Print from Build file
- +1 NEW DIRUT,XPDIT,XPDCNT
- +2 SET (XPDIT,XPDCNT)=0
- +3 FOR
- SET XPDIT=$ORDER(XPDT(XPDIT))
- IF $DATA(DIRUT)!(XPDIT'>0)
- QUIT
- Begin DoDot:1
- +4 IF XPDCNT
- IF '$$CONT
- QUIT
- +5 SET XPDCNT=XPDCNT+1
- +6 SET D0=+XPDT(XPDIT)
- DO PNT^XPDDP1("XPD(9.6,D0)")
- End DoDot:1
- IF $DATA(DIRUT)
- QUIT
- +7 DO WAIT
- +8 QUIT
- +9 ;
- LST2 ; Print from XPDT array
- +1 NEW DIRUT,XPDIT,XPDCNT
- +2 SET (XPDIT,XPDCNT)=0
- +3 FOR
- SET XPDIT=$ORDER(XPDT(XPDIT))
- IF $DATA(DIRUT)!(XPDIT'>0)
- QUIT
- Begin DoDot:1
- +4 IF XPDCNT
- IF '$$CONT
- QUIT
- +5 SET XPDCNT=XPDCNT+1
- SET XPDA=+XPDT(XPDIT)
- SET D0=$ORDER(^XTMP("XPDI",XPDA,"BLD",0))
- +6 IF XPDP<3
- DO PNT^XPDDP1("XTMP(""XPDI"",XPDA,""BLD"",D0)")
- IF XPDP>1
- DO RTN
- End DoDot:1
- IF $DATA(DIRUT)
- QUIT
- +7 DO WAIT
- +8 QUIT
- +9 ;
- XMP2(X,D0) ;called from ^XMP2
- +1 NEW XPDA
- SET XPDA=-1
- +2 DO PNT^XPDDP1(X)
- +3 QUIT
- +4 ;
- WAIT ; Pause on last page or not? It depends on whether there's enough room
- +1 ; left on the page to display the KIDS menu.
- +2 IF $EXTRACT($GET(IOST),1,2)'="C-"
- QUIT
- +3 IF $DATA(DIRUT)
- QUIT
- +4 ; DUZ("AUTO")=1 means show menu option choices
- +5 IF IOSL-$Y<$SELECT($GET(DUZ("AUTO")):14,1:3)
- DO WAIT^XMXUTIL
- +6 QUIT
- +7 ;
- CONT() ; Press Return to continue; ^ to exit.
- +1 IF $DATA(DIRUT)
- QUIT 0
- +2 IF $EXTRACT(IOST,1,2)'="C-"
- QUIT 1
- +3 NEW DIR,I,J,K,X,Y
- +4 SET DIR(0)="E"
- DO ^DIR
- +5 QUIT Y
- +6 ;
- CHK(Y) ;Y=excess lines, return 1 to exit
- +1 ;return 0 to continue
- +2 IF $Y<(IOSL-Y)
- QUIT 0
- +3 IF '$$CONT
- QUIT 1
- +4 WRITE @IOF
- +5 QUIT 0
- +6 ;
- RTN ;Print Routines
- +1 IF $DATA(DIRUT)!$$CHK(2)
- QUIT
- +2 NEW XPD0,XPDI,XPDRTN
- +3 SET XPD0=$GET(^XTMP("XPDI",XPDA,"BLD",D0,0))
- IF XPD0=""
- QUIT
- +4 IF XPDP=3
- NEW XPDDT,XPDPG,XPDUL
- Begin DoDot:1
- +5 SET XPDDT=$$HTE^XLFDT($HOROLOG,"1PM")
- SET XPDPG=1
- SET $PIECE(XPDUL,"-",IOM)=""
- +6 DO HDR^XPDDP1
- +7 WRITE !,XPDUL
- End DoDot:1
- +8 SET XPDRTN=""
- +9 FOR
- SET XPDRTN=$ORDER(^XTMP("XPDI",XPDA,"RTN",XPDRTN))
- IF XPDRTN=""
- QUIT
- Begin DoDot:1
- +10 WRITE !,XPDRTN
- SET XPDI=0
- +11 FOR
- SET XPDI=$ORDER(^XTMP("XPDI",XPDA,"RTN",XPDRTN,XPDI))
- IF 'XPDI
- QUIT
- WRITE !,$GET(^(XPDI,0))
- IF $$CHK(2)
- QUIT
- +12 WRITE !
- IF '$$CHK(2)
- QUIT
- End DoDot:1
- IF $DATA(DIRUT)
- QUIT
- +13 WRITE !!
- SET DIRUT=1
- +14 QUIT
