- DIFGO ;SFISC/XAK-FILEGRAM OPTIONS ;10:15 AM 7 Aug 2002
- ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
- ;;Per VA Directive 6402, this routine should not be modified.
- ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
- ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
- ;;Licensed under the terms of the Apache License, Version 2.0.
- ;
- 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 X ^DD("DD")
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIFGO 2133 printed Feb 19, 2025@00:14:09 Page 2
- DIFGO ;SFISC/XAK-FILEGRAM OPTIONS ;10:15 AM 7 Aug 2002
- +1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
- +4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
- +5 ;;Licensed under the terms of the Apache License, Version 2.0.
- +6 ;
- 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 XECUTE ^DD("DD")
- +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
