- PRCD1F ;WISC/PLT-SUBSTATION ENTER/EDIT ; 08/03/95 2:33 PM
- V ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- QUIT ;invalid entry
- ;
- ;enter/edit substation
- EN N PRCDD,PRCDR,PRCRI,PRCAED,PRCQT,PRCU,A,B,X,Y S PRCU="^"
- N PRCUQ
- F D EN^DDIOL($TR($J("",78)," ","-")) D Q:PRCQT=1
- . S PRCDD=411,PRCQT=""
- . S PRCUQ=""
- . D LKUP Q:PRCQT
- . S PRCLOCK=$$DICGL^PRC0B1(PRCDD)_PRCRI(PRCDD)_",",Y=3 D ICLOCK^PRC0B(PRCLOCK,.Y)
- . I 'Y D EN^DDIOL("File is in use, please try later!") QUIT
- . D EDIT
- . D DCLOCK^PRC0B(PRCLOCK)
- . QUIT
- QUIT
- ;
- LKUP ;lookup prcdd=411
- S DA="",X("S")="I +Y>1000000"
- S DA="" D LOOKUP^PRC0B(.X,.Y,PRCDD,"AEMOQLS","Select SUBSTATION: ")
- I Y<0!(X="") S PRCQT=1 QUIT
- S DA=+Y,PRCRI(PRCDD)=+Y,PRCAED=$P(Y,"^",3)
- I PRCAED=1,DA<1000000!($P(Y,"^",2)?3N) D EN^DDIOL("Use option 'Site Parameters' to add new station.") D DELETE S PRCQT=2
- I PRCAED=1,'$D(^PRC(411,$E($P(Y,"^",2),1,3),0)) D EN^DDIOL("Use option 'Site Parameters' to set up the parent station first.") D DELETE S PRCQT=2
- QUIT
- ;
- EDIT ;edit prcdd=411
- S PRCDR="[PRCD SUBSTATION]",C=PRCDR
- ED1 D EDIT^PRC0B(.X,PRCDD_";;"_PRCRI(PRCDD),C) I X=0 S PRCQT=2 QUIT
- I X=-1,PRCAED=1 D Q:PRCQT
- . D YN^PRC0A(.X,.Y,"Delete this NEW entry","","No")
- . I Y=1 D DELETE I PRCAED=-1 D EN^DDIOL(" **** NEW ENTRY DELETED ****") S PRCQT=3 QUIT
- . D EN^DDIOL(" **** NEW ENTRY IS NOT DELETED ****")
- .QUIT
- ;require fileds check
- S C="101;"
- EDA K A D PIECE^PRC0B(PRCDD_";;"_PRCRI(PRCDD),C,"I","A")
- S C="" F A=101 I $G(A(PRCDD,PRCRI(PRCDD),A,"I"))="" S C=C_A_";"
- K A I C]"" D EN^DDIOL(" **** Missing Required Field(s) ****") S C=C_"S Y=0;"_PRCDR G ED1
- QUIT
- ;
- DELETE ;delete prcdd=411
- D DELETE^PRC0B1(.X,PRCDD_";^PRC(411,;"_PRCRI(PRCDD))
- S:X=1 PRCAED=-1
- QUIT
- ;
- EN1 ;print file 411
- N L,DIC,FLDS,BY,FR,TO,DHD,PRCDD
- S PRCDD=411
- S L=0,DIC=PRCDD,FLDS=".01,.1,.5,19.2"
- S BY="@.01",FR="@",TO="~"
- D EN1^DIP
- QUIT
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCD1F 1977 printed Jan 18, 2025@03:02:17 Page 2
- PRCD1F ;WISC/PLT-SUBSTATION ENTER/EDIT ; 08/03/95 2:33 PM
- V ;;5.1;IFCAP;;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +2 ;invalid entry
- QUIT
- +3 ;
- +4 ;enter/edit substation
- EN NEW PRCDD,PRCDR,PRCRI,PRCAED,PRCQT,PRCU,A,B,X,Y
- SET PRCU="^"
- +1 NEW PRCUQ
- +2 FOR
- DO EN^DDIOL($TRANSLATE($JUSTIFY("",78)," ","-"))
- Begin DoDot:1
- +3 SET PRCDD=411
- SET PRCQT=""
- +4 SET PRCUQ=""
- +5 DO LKUP
- if PRCQT
- QUIT
- +6 SET PRCLOCK=$$DICGL^PRC0B1(PRCDD)_PRCRI(PRCDD)_","
- SET Y=3
- DO ICLOCK^PRC0B(PRCLOCK,.Y)
- +7 IF 'Y
- DO EN^DDIOL("File is in use, please try later!")
- QUIT
- +8 DO EDIT
- +9 DO DCLOCK^PRC0B(PRCLOCK)
- +10 QUIT
- End DoDot:1
- if PRCQT=1
- QUIT
- +11 QUIT
- +12 ;
- LKUP ;lookup prcdd=411
- +1 SET DA=""
- SET X("S")="I +Y>1000000"
- +2 SET DA=""
- DO LOOKUP^PRC0B(.X,.Y,PRCDD,"AEMOQLS","Select SUBSTATION: ")
- +3 IF Y<0!(X="")
- SET PRCQT=1
- QUIT
- +4 SET DA=+Y
- SET PRCRI(PRCDD)=+Y
- SET PRCAED=$PIECE(Y,"^",3)
- +5 IF PRCAED=1
- IF DA<1000000!($PIECE(Y,"^",2)?3N)
- DO EN^DDIOL("Use option 'Site Parameters' to add new station.")
- DO DELETE
- SET PRCQT=2
- +6 IF PRCAED=1
- IF '$DATA(^PRC(411,$EXTRACT($PIECE(Y,"^",2),1,3),0))
- DO EN^DDIOL("Use option 'Site Parameters' to set up the parent station first.")
- DO DELETE
- SET PRCQT=2
- +7 QUIT
- +8 ;
- EDIT ;edit prcdd=411
- +1 SET PRCDR="[PRCD SUBSTATION]"
- SET C=PRCDR
- ED1 DO EDIT^PRC0B(.X,PRCDD_";;"_PRCRI(PRCDD),C)
- IF X=0
- SET PRCQT=2
- QUIT
- +1 IF X=-1
- IF PRCAED=1
- Begin DoDot:1
- +2 DO YN^PRC0A(.X,.Y,"Delete this NEW entry","","No")
- +3 IF Y=1
- DO DELETE
- IF PRCAED=-1
- DO EN^DDIOL(" **** NEW ENTRY DELETED ****")
- SET PRCQT=3
- QUIT
- +4 DO EN^DDIOL(" **** NEW ENTRY IS NOT DELETED ****")
- +5 QUIT
- End DoDot:1
- if PRCQT
- QUIT
- +6 ;require fileds check
- +7 SET C="101;"
- EDA KILL A
- DO PIECE^PRC0B(PRCDD_";;"_PRCRI(PRCDD),C,"I","A")
- +1 SET C=""
- FOR A=101
- IF $GET(A(PRCDD,PRCRI(PRCDD),A,"I"))=""
- SET C=C_A_";"
- +2 KILL A
- IF C]""
- DO EN^DDIOL(" **** Missing Required Field(s) ****")
- SET C=C_"S Y=0;"_PRCDR
- GOTO ED1
- +3 QUIT
- +4 ;
- DELETE ;delete prcdd=411
- +1 DO DELETE^PRC0B1(.X,PRCDD_";^PRC(411,;"_PRCRI(PRCDD))
- +2 if X=1
- SET PRCAED=-1
- +3 QUIT
- +4 ;
- EN1 ;print file 411
- +1 NEW L,DIC,FLDS,BY,FR,TO,DHD,PRCDD
- +2 SET PRCDD=411
- +3 SET L=0
- SET DIC=PRCDD
- SET FLDS=".01,.1,.5,19.2"
- +4 SET BY="@.01"
- SET FR="@"
- SET TO="~"
- +5 DO EN1^DIP
- +6 QUIT
- +7 ;