DIFGO ;SFISC/XAK-FILEGRAM OPTIONS ;5:13 AM 7 Jun 2000 [ 04/02/2003 8:25 AM ]
;;22.0;VA FileMan;**1001**;APR 1, 2003
;;22.0;VA FileMan;**47**;Mar 30, 1999;
;Per VHA Directive 10-93-142, this routine should not be modified.
0 S DIC="^DOPT(""DIFG"","
G OPT:$D(^DOPT("DIFG",6)) S ^(0)="FILEGRAM OPTION^1.01" K ^("B")
F X=1:1:6 S ^DOPT("DIFG",X,0)=$P($T(@X),";;",2)
S DIK=DIC D IXALL^DIK
OPT ;
S DIC(0)="AEQIZ" D ^DIC G Q:Y<0 S DI=+Y D EN G 0
;
EN ;Entry point for all filegram options
S:'$D(Y) Y=0 S DIC("S")="I Y>1.99" D:DI#2 ^DICRW G:Y<0 Q K DIC("S") ;ihs/ohprd/dg 8-21-91
D @DI W !!
Q K %,DIC,DIK,DI,DA,I,J,X,Y Q
;
1 ;;CREATE/EDIT FILEGRAM TEMPLATE
G EN^DIFGA
;
2 ;;DISPLAY FILEGRAM TEMPLATE
S DIC("A")="Select FILEGRAM TEMPLATE: "
S DIC="^DIPT(",DIC(0)="QEAM",DIC("S")="I $P(^(0),U,8)=1" D ^DIC I Y<0 K DIC Q
W !! S DA=+Y,DIQ(0)="C" D EN^DIQ K DIC,DIQ G 2
Q
;
3 ;;GENERATE FILEGRAM
I '($D(IO)#2) D HOME^%ZIS
I DUZ'>0 W $C(7),!!,"INVALID USER. YOU CAN'T USE THIS OPTION." Q
S DIC=+Y G ^DIFGG
;
;
4 ;;VIEW FILEGRAM
W !! S DIC(0)="ZQEAMIN",DIC=1.12 D ^DIC Q:Y<0 S IOP="HOME" D ^%ZIS Q:POP
S D0=+Y D EN1 G 4
EN1 S X=Y(0),Y=$P(X,U,6),Y=$S($D(^XMB(3.9,+Y,0))#2:$P(^(0),U),1:Y) W !!,Y
S Y=$P(X,U,2) W !,$S(Y="s":"Sent",Y="i":"Installed",1:Y)
W " on " S Y=$P(X,U) D DT W " by ",$P(X,U,3)
S DIWL=1,DIWR=78,DIWF="WN" S D0=$P(X,U,6) S:'$D(^XMB(3.9,+D0,0)) D0=-1
W !! S S=5,D=0 F S (D,D1)=$O(^XMB(3.9,D0,2,D)) Q:D'>0 I $D(^(D,0))#2 S X=^(0) D ^DIWP Q:'$D(D) S D=D1,S=S+1 I $E(IOST)="C",S+4>IOSL S DIR(0)="E" D ^DIR Q:'Y S S=0
S:D="" (D,D1)=-1 D 0^DIWW K DIP,Y,DIWF
Q
DT I Y W $E(Y,6,7)," ",$P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",U,$E(Y,4,5))_" ",Y\10000+1700 W:Y#1 " @ "_$E(Y_0,9,10)_":"_$E(Y_"000",11,12) Q
W Y Q
;
5 ;;SPECIFIERS
S DI=+Y G 99^DIU
;
6 ;;INSTALL/VERIFY FILEGRAM
S DIC(0)="QEAMNIZ",DIC=1.12 D ^DIC K DIC Q:Y<0 Q:'$P(Y(0),U,6)
S DIFGLO="^XMB(3.9,"_$P(Y(0),U,6)_",2,",DIFGG=+Y
D ^DIFG W !,$S($D(DIFGER):"UNSUCCESSFUL INSTALLATION: "_DIFGER,1:"DONE")
S $P(^DIAR(1.12,DIFGG,0),U,2)=$S($D(DIFGER):"u",1:"i") K DIFGER,DIFGG Q
DIFGO ;SFISC/XAK-FILEGRAM OPTIONS ;5:13 AM 7 Jun 2000 [ 04/02/2003 8:25 AM ]
+1 ;;22.0;VA FileMan;**1001**;APR 1, 2003
+2 ;;22.0;VA FileMan;**47**;Mar 30, 1999;
+3 ;Per VHA Directive 10-93-142, this routine should not be modified.
0 SET DIC="^DOPT(""DIFG"","
+1 IF $DATA(^DOPT("DIFG",6))
GOTO OPT
SET ^(0)="FILEGRAM OPTION^1.01"
KILL ^("B")
+2 FOR X=1:1:6
SET ^DOPT("DIFG",X,0)=$PIECE($TEXT(@X),";;",2)
+3 SET DIK=DIC
DO IXALL^DIK
OPT ;
+1 SET DIC(0)="AEQIZ"
DO ^DIC
IF Y<0
GOTO Q
SET DI=+Y
DO EN
GOTO 0
+2 ;
EN ;Entry point for all filegram options
+1 ;ihs/ohprd/dg 8-21-91
IF '$DATA(Y)
SET Y=0
SET DIC("S")="I Y>1.99"
IF DI#2
DO ^DICRW
IF Y<0
GOTO Q
KILL DIC("S")
+2 DO @DI
WRITE !!
Q KILL %,DIC,DIK,DI,DA,I,J,X,Y
QUIT
+1 ;
1 ;;CREATE/EDIT FILEGRAM TEMPLATE
+1 GOTO EN^DIFGA
+2 ;
2 ;;DISPLAY FILEGRAM TEMPLATE
+1 SET DIC("A")="Select FILEGRAM TEMPLATE: "
+2 SET DIC="^DIPT("
SET DIC(0)="QEAM"
SET DIC("S")="I $P(^(0),U,8)=1"
DO ^DIC
IF Y<0
KILL DIC
QUIT
+3 WRITE !!
SET DA=+Y
SET DIQ(0)="C"
DO EN^DIQ
KILL DIC,DIQ
GOTO 2
+4 QUIT
+5 ;
3 ;;GENERATE FILEGRAM
+1 IF '($DATA(IO)#2)
DO HOME^%ZIS
+2 IF DUZ'>0
WRITE $CHAR(7),!!,"INVALID USER. YOU CAN'T USE THIS OPTION."
QUIT
+3 SET DIC=+Y
GOTO ^DIFGG
+4 ;
+5 ;
4 ;;VIEW FILEGRAM
+1 WRITE !!
SET DIC(0)="ZQEAMIN"
SET DIC=1.12
DO ^DIC
IF Y<0
QUIT
SET IOP="HOME"
DO ^%ZIS
IF POP
QUIT
+2 SET D0=+Y
DO EN1
GOTO 4
EN1 SET X=Y(0)
SET Y=$PIECE(X,U,6)
SET Y=$SELECT($DATA(^XMB(3.9,+Y,0))#2:$PIECE(^(0),U),1:Y)
WRITE !!,Y
+1 SET Y=$PIECE(X,U,2)
WRITE !,$SELECT(Y="s":"Sent",Y="i":"Installed",1:Y)
+2 WRITE " on "
SET Y=$PIECE(X,U)
DO DT
WRITE " by ",$PIECE(X,U,3)
+3 SET DIWL=1
SET DIWR=78
SET DIWF="WN"
SET D0=$PIECE(X,U,6)
IF '$DATA(^XMB(3.9,+D0,0))
SET D0=-1
+4 WRITE !!
SET S=5
SET D=0
FOR
SET (D,D1)=$ORDER(^XMB(3.9,D0,2,D))
IF D'>0
QUIT
IF $DATA(^(D,0))#2
SET X=^(0)
DO ^DIWP
IF '$DATA(D)
QUIT
SET D=D1
SET S=S+1
IF $EXTRACT(IOST)="C"
IF S+4>IOSL
SET DIR(0)="E"
DO ^DIR
IF 'Y
QUIT
SET S=0
+5 IF D=""
SET (D,D1)=-1
DO 0^DIWW
KILL DIP,Y,DIWF
+6 QUIT
DT IF Y
WRITE $EXTRACT(Y,6,7)," ",$PIECE("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",U,$EXTRACT(Y,4,5))_" ",Y\10000+1700
IF Y#1
WRITE " @ "_$EXTRACT(Y_0,9,10)_":"_$EXTRACT(Y_"000",11,12)
QUIT
+1 WRITE Y
QUIT
+2 ;
5 ;;SPECIFIERS
+1 SET DI=+Y
GOTO 99^DIU
+2 ;
6 ;;INSTALL/VERIFY FILEGRAM
+1 SET DIC(0)="QEAMNIZ"
SET DIC=1.12
DO ^DIC
KILL DIC
IF Y<0
QUIT
IF '$PIECE(Y(0),U,6)
QUIT
+2 SET DIFGLO="^XMB(3.9,"_$PIECE(Y(0),U,6)_",2,"
SET DIFGG=+Y
+3 DO ^DIFG
WRITE !,$SELECT($DATA(DIFGER):"UNSUCCESSFUL INSTALLATION: "_DIFGER,1:"DONE")
+4 SET $PIECE(^DIAR(1.12,DIFGG,0),U,2)=$SELECT($DATA(DIFGER):"u",1:"i")
KILL DIFGER,DIFGG
QUIT
