- DVBCPUSH ;ALB/AKG - CAPRI PUSH UTILITY RPC; APR 25, 2022@9:30am ; 5/19/23 9:07am
- ;;2.7;AMIE;**238,242,248**;Apr 10, 1995;Build 6
- ;Per VHA Directive 6402 this routine should not be modified
- ;ICR #2263 Supports all calls to Parameter File and XPAR usage
- ;
- Q
- ;
- PARAMS(DVBLIST) ;returns data on the entire DVBA parameter list
- ;rpc returns all CAPRI namespaced Paramaters
- K DVBLIST
- N DVBCNT,DVBPARAM,DVBVAL,DVBPAR
- S DVBCNT=0
- S DVBPARAM="" F S DVBPARAM=$O(^XTV(8989.51,"B",DVBPARAM)) Q:DVBPARAM="" D
- .S DVBPAR="" F S DVBPAR=$O(^XTV(8989.51,"B",DVBPARAM,DVBPAR)) Q:DVBPAR="" D
- ..I $P($P(DVBPARAM,U,1)," ")'["DVBA" Q
- ..S DVBVAL=$$GET^XPAR("PKG",DVBPARAM,1,"Q")
- ..S DVBLIST(DVBCNT)=DVBPAR_U_DVBPARAM_U_DVBVAL
- ..S DVBCNT=DVBCNT+1
- Q
- ;
- PARAMED(DVBMSG,DVBNAME,DVBVAL) ;
- ;edits exiting paramater value from CAPRI Push Utility
- I $G(DVBNAME)="" S DVBMSG="Missing parameter name" Q
- I $G(DVBVAL)="" S DVBMSG="Missing new value" Q
- K DVBMSG S DVBMSG=""
- N DVBERR,DVBINFO,DVBOLD
- S DVBOLD=$$GET^XPAR("PKG",DVBNAME,1,"Q")
- D EN^XPAR("PKG.AUTOMATED MED INFO EXCHANGE",DVBNAME,1,DVBVAL,.DVBERR)
- I DVBERR S DVBMSG="Failed to update because "_DVBERR_U_0 Q
- S DVBINFO=$$GET^XPAR("PKG",DVBNAME,1,"Q")
- S DVBMSG=DVBNAME_" value updated successfully from "_DVBOLD_" to "_DVBINFO_U_1
- Q
- ;
- PARADESC(DVBRTN,DVBIEN) ;
- ;returns description for selected parameter
- N DVBX,DVBTWP,DVBERR,DVBCT,DVBRT,DVBIENS,DVBTMP
- I $G(DVBIEN)="" S DVBRTN="Missing Parameter IEN" Q
- D GETS^DIQ(8989.51,DVBIEN,20,"","DVBTWP","DVBERR")
- I $D(DVBERR) S DVBRTN=DVBERR Q
- K DVBTMP M DVBTMP=DVBTWP
- S DVBIENS=""_DVBIEN_","
- I $D(DVBTMP) D
- .S DVBCT="",DVBX="" F S DVBX=$O(DVBTMP(8989.51,DVBIENS,20,DVBX)) Q:DVBX="" D
- ..S DVBCT=DVBCT+1
- ..S DVBRT(DVBCT)=DVBTMP(8989.51,DVBIENS,20,DVBX)
- M DVBRTN=DVBRT
- K DVBRT,DVBTWP
- Q
- ;
- EFOLDMET(DVBRTN,DVBAUTH,DVBPIEN,DVBTRANS,DVBSTAT,DVBERR,DVBRPD) ;
- ;Input: DVBAUTH=Authorized User IEN
- ; DVBPIEN=Patient IEN
- ; DVBTRANS=Transmission Path
- ; DVBSTAT=Transmission Status
- ; DVBERR=Transmission Error Code
- ; DVBRPD=Report Details
- ;Output: RTN=0 for Failure and 1 for Success
- ;
- N DVBDT,DIC,X,Y,DA,DTOUT,DUOUT,DLAYGO,DVBI,DVBRPC,DVBN1,DVBAIEN,DVBNUM
- I DVBAUTH="" S DVBRTN="0^MISSING AUTHORIZED USER IEN" Q
- I DVBPIEN="" S DVBRTN="0^MISSING PATIENT IEN" Q
- I DVBTRANS="" S DVBRTN="0^MISSING TRANSMISSION PATH" Q
- I DVBSTAT="" S DVBRTN="0^MISSING TRANSMISSION STATUS" Q
- S DVBDT=$$NOW^XLFDT()
- K DIC,DIE,DR,DA
- S (DIC,DIE)="^DVB(396.21,",DIC(0)="L",DLAYGO=396.21 S X=DVBDT
- D ^DIC S DA=+Y K DIC
- I DA=-1 S DVBRTN=0 Q
- S DVBRTN=1
- S DR=".02////"_DVBAUTH_";.03////"_DVBPIEN_";1////"_DVBTRANS D ^DIE
- S DR="1.1////"_DVBSTAT_";1.2////"_DVBERR D ^DIE
- S DVBNUM=DA
- S DVBI="" F S DVBI=$O(DVBRPD(DVBI)) Q:DVBI="" D
- .S DA(1)=DVBNUM
- .S DIC="^DVB(396.21,"_DA(1)_",2,",DIC(0)="L"
- .D ^DIC S DA=+Y
- .S DIE=DIC
- .S DVBRPC=$P(DVBRPD(DVBI),U),DVBAIEN=$P(DVBRPD(DVBI),U,2)
- .S DVBN1=$P(DVBRPD(DVBI),U,3,100)
- .S DR=".01////"_DVBRPC_";.02////"_DVBAIEN_";.03////"_DVBN1
- .D ^DIE
- K DIC,DIE,DA,DR,DIRUT
- Q
- ;
- PURGEMET(DVBRTN,DUZ,DVBDTP) ;
- ;
- ;input: DUZ user must have the DVBA METRICS DATA PURGE key
- ; : Date to purge up to
- N DVBDT,DVBDA,DVBKEY,DVBDATE
- I DUZ="" S DVBRTN="0^Missing DUZ" Q
- I DVBDTP="" S DVBRTN="0^Missing Date" Q
- S X=DVBDTP D ^%DT S DVBDATE=Y
- D OWNSKEY^XUSRB(.DVBKEY,"DVBA CAPRI METRICS PURGE",DUZ)
- I DVBKEY(0)=0 S DVBRTN="0^Missing security key" Q
- S DVBDT="" F S DVBDT=$O(^DVB(396.21,"B",DVBDT)) Q:DVBDT="" D
- .S DVBDA="" F S DVBDA=$O(^DVB(396.21,"B",DVBDT,DVBDA)) Q:DVBDA="" D
- ..I $P(DVBDT,".")>DVBDATE Q
- ..K DIC,DA,DIK
- ..S DIC="^DVB(396.21,",DA=DVBDA
- ..S DIK=DIC D ^DIK K DIK,DIC
- ..S DVBRTN=1
- I $G(DVBRTN)'=1 S DVBRTN="-1"
- Q
- PURGEOPT ;
- W !!,"CAPRI CLINICAL DOCUMENTS EFOLDER METRIC DATA PURGE",!!
- S DIR("?")="Enter date to purge CAPRI Clinical Documents EFolder Metrics file up to. For Example,to purge from today and older enter today's date"
- S DIR("A")="Enter date to purge CAPRI Clinical Documents EFolder Metrics file."
- S DIR(0)="D" D ^DIR K DIR Q:$D(DIRUT)!($D(DTOUT))
- D PURGEMET(.DVBRTN,DUZ,Y)
- I DVBRTN["Miss" W !!,"Missing Security Key, please check with your manager for additional assistance" Q
- I DVBRTN'=1 W !!,"No records were purged",!! D PURGEOPT Q
- I DVBRTN=1 W !!,"Purge completed"
- Q
- ALL(DVBLIST) ;
- K DVBLIST
- N DVBCNT,DVBPARAM,DVBVAL,DVBPAR,DVBSIY,DVBSIEN,DVBZ,DVBERR
- S DVBCNT=0
- S DVBPARAM="" F S DVBPARAM=$O(^XTV(8989.51,"B",DVBPARAM)) Q:DVBPARAM="" D
- .S DVBPAR="" F S DVBPAR=$O(^XTV(8989.51,"B",DVBPARAM,DVBPAR)) Q:DVBPAR="" D
- ..S DVBZ="30*" K DVBSIY D GETS^DIQ(8989.51,DVBPAR,DVBZ,"I","DVBSIY","DVBERR") I $D(DVBERR) Q
- ..S DVBSIEN="" F S DVBSIEN=$O(DVBSIY(8989.513,DVBSIEN)) Q:DVBSIEN="" D
- ...N DVBENT S DVBENT=DVBSIY(8989.513,DVBSIEN,.02,"I") I DVBENT'=9.4 Q
- ...I DVBPARAM["XPAR" Q
- ...S DVBVAL=$$GET^XPAR("ALL",DVBPARAM,1,"Q")
- ...S DVBLIST(DVBCNT)=DVBPARAM_U_DVBVAL
- ...S DVBCNT=DVBCNT+1
- Q
- SPECADD(DVBMSG,DVBNAME) ;
- ;adds entry to Special Considerations
- I $G(DVBNAME)="" S DVBMSG="0^Missing Special Considerations name" Q
- K DVBMSG S DVBMSG="",DVBIEN=0
- F S DVBIEN=$O(^DVB(396.25,DVBIEN)) Q:DVBIEN=""!('DVBIEN) D
- .I $P(^DVB(396.25,DVBIEN,0),U,1)=DVBNAME S DVBMSG="0^Duplicate"
- .Q
- I DVBMSG="" D
- .K DIC,DO,DIE,DA,DR,DLAYGO,X,Y
- .N DIERR
- .S DIC=396.25,DIC(0)="Z",X=DVBNAME D FILE^DICN
- .S (DA)=+Y,DIE=DIC
- .S DR=".02////1" D ^DIE
- .I $D(DIERR) S DVBMSG="0^Record not added"
- .I '$D(DIERR) S DVBMSG="1^Record added"
- .K DIC,DO,DIE,DA,DR,DLAYGO,X,Y
- .Q
- Q
- SPECDIS(DVBMSG,DVBIEN,DVBSTAT) ;
- ;disables entry in Special Considerations
- N DIERR
- K DIC,DIE,DA,DR,DLAYGO,X,Y
- I $G(DVBIEN)="" S DVBMSG="0^Missing IEN" Q
- I $G(DVBSTAT)="" S DVBMSG="0^Missing Status" Q
- S DA=DVBIEN,(DLAYGO,DIE)="^DVB(396.25,",DIC(0)="L"
- S DR=".02////"_DVBSTAT D ^DIE
- I $D(DIERR) S DVBMSG="0^Record not disabled"
- I '$D(DIERR) S DVBMSG="1^Record disabled"
- K DIC,DIE,DA,DR,DLAYGO,X,Y
- Q
- LISTSC(DVBMSG) ;
- ;list inactive Special Considerations
- N DVBIEN,DVBCNT,DVBRET
- K ^TMP("DVBLSTSC",$J)
- S DVBIEN=0,DVBCNT=0
- F S DVBIEN=$O(^DVB(396.25,DVBIEN)) Q:DVBIEN=""!('DVBIEN) D
- .Q:$G(^DVB(396.25,DVBIEN,0))=""
- .Q:$P($G(^DVB(396.25,DVBIEN,0)),U,2)'=0
- .S DVBRET(DVBCNT)=$P(^DVB(396.25,DVBIEN,0),"^",1)_"^"_DVBIEN
- .M ^TMP("DVBLSTSC",$J,DVBCNT)=DVBRET(DVBCNT)
- .S DVBCNT=DVBCNT+1
- S DVBMSG=$NA(^TMP("DVBLSTSC",$J))
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCPUSH 6484 printed Jan 18, 2025@02:46:37 Page 2
- DVBCPUSH ;ALB/AKG - CAPRI PUSH UTILITY RPC; APR 25, 2022@9:30am ; 5/19/23 9:07am
- +1 ;;2.7;AMIE;**238,242,248**;Apr 10, 1995;Build 6
- +2 ;Per VHA Directive 6402 this routine should not be modified
- +3 ;ICR #2263 Supports all calls to Parameter File and XPAR usage
- +4 ;
- +5 QUIT
- +6 ;
- PARAMS(DVBLIST) ;returns data on the entire DVBA parameter list
- +1 ;rpc returns all CAPRI namespaced Paramaters
- +2 KILL DVBLIST
- +3 NEW DVBCNT,DVBPARAM,DVBVAL,DVBPAR
- +4 SET DVBCNT=0
- +5 SET DVBPARAM=""
- FOR
- SET DVBPARAM=$ORDER(^XTV(8989.51,"B",DVBPARAM))
- if DVBPARAM=""
- QUIT
- Begin DoDot:1
- +6 SET DVBPAR=""
- FOR
- SET DVBPAR=$ORDER(^XTV(8989.51,"B",DVBPARAM,DVBPAR))
- if DVBPAR=""
- QUIT
- Begin DoDot:2
- +7 IF $PIECE($PIECE(DVBPARAM,U,1)," ")'["DVBA"
- QUIT
- +8 SET DVBVAL=$$GET^XPAR("PKG",DVBPARAM,1,"Q")
- +9 SET DVBLIST(DVBCNT)=DVBPAR_U_DVBPARAM_U_DVBVAL
- +10 SET DVBCNT=DVBCNT+1
- End DoDot:2
- End DoDot:1
- +11 QUIT
- +12 ;
- PARAMED(DVBMSG,DVBNAME,DVBVAL) ;
- +1 ;edits exiting paramater value from CAPRI Push Utility
- +2 IF $GET(DVBNAME)=""
- SET DVBMSG="Missing parameter name"
- QUIT
- +3 IF $GET(DVBVAL)=""
- SET DVBMSG="Missing new value"
- QUIT
- +4 KILL DVBMSG
- SET DVBMSG=""
- +5 NEW DVBERR,DVBINFO,DVBOLD
- +6 SET DVBOLD=$$GET^XPAR("PKG",DVBNAME,1,"Q")
- +7 DO EN^XPAR("PKG.AUTOMATED MED INFO EXCHANGE",DVBNAME,1,DVBVAL,.DVBERR)
- +8 IF DVBERR
- SET DVBMSG="Failed to update because "_DVBERR_U_0
- QUIT
- +9 SET DVBINFO=$$GET^XPAR("PKG",DVBNAME,1,"Q")
- +10 SET DVBMSG=DVBNAME_" value updated successfully from "_DVBOLD_" to "_DVBINFO_U_1
- +11 QUIT
- +12 ;
- PARADESC(DVBRTN,DVBIEN) ;
- +1 ;returns description for selected parameter
- +2 NEW DVBX,DVBTWP,DVBERR,DVBCT,DVBRT,DVBIENS,DVBTMP
- +3 IF $GET(DVBIEN)=""
- SET DVBRTN="Missing Parameter IEN"
- QUIT
- +4 DO GETS^DIQ(8989.51,DVBIEN,20,"","DVBTWP","DVBERR")
- +5 IF $DATA(DVBERR)
- SET DVBRTN=DVBERR
- QUIT
- +6 KILL DVBTMP
- MERGE DVBTMP=DVBTWP
- +7 SET DVBIENS=""_DVBIEN_","
- +8 IF $DATA(DVBTMP)
- Begin DoDot:1
- +9 SET DVBCT=""
- SET DVBX=""
- FOR
- SET DVBX=$ORDER(DVBTMP(8989.51,DVBIENS,20,DVBX))
- if DVBX=""
- QUIT
- Begin DoDot:2
- +10 SET DVBCT=DVBCT+1
- +11 SET DVBRT(DVBCT)=DVBTMP(8989.51,DVBIENS,20,DVBX)
- End DoDot:2
- End DoDot:1
- +12 MERGE DVBRTN=DVBRT
- +13 KILL DVBRT,DVBTWP
- +14 QUIT
- +15 ;
- EFOLDMET(DVBRTN,DVBAUTH,DVBPIEN,DVBTRANS,DVBSTAT,DVBERR,DVBRPD) ;
- +1 ;Input: DVBAUTH=Authorized User IEN
- +2 ; DVBPIEN=Patient IEN
- +3 ; DVBTRANS=Transmission Path
- +4 ; DVBSTAT=Transmission Status
- +5 ; DVBERR=Transmission Error Code
- +6 ; DVBRPD=Report Details
- +7 ;Output: RTN=0 for Failure and 1 for Success
- +8 ;
- +9 NEW DVBDT,DIC,X,Y,DA,DTOUT,DUOUT,DLAYGO,DVBI,DVBRPC,DVBN1,DVBAIEN,DVBNUM
- +10 IF DVBAUTH=""
- SET DVBRTN="0^MISSING AUTHORIZED USER IEN"
- QUIT
- +11 IF DVBPIEN=""
- SET DVBRTN="0^MISSING PATIENT IEN"
- QUIT
- +12 IF DVBTRANS=""
- SET DVBRTN="0^MISSING TRANSMISSION PATH"
- QUIT
- +13 IF DVBSTAT=""
- SET DVBRTN="0^MISSING TRANSMISSION STATUS"
- QUIT
- +14 SET DVBDT=$$NOW^XLFDT()
- +15 KILL DIC,DIE,DR,DA
- +16 SET (DIC,DIE)="^DVB(396.21,"
- SET DIC(0)="L"
- SET DLAYGO=396.21
- SET X=DVBDT
- +17 DO ^DIC
- SET DA=+Y
- KILL DIC
- +18 IF DA=-1
- SET DVBRTN=0
- QUIT
- +19 SET DVBRTN=1
- +20 SET DR=".02////"_DVBAUTH_";.03////"_DVBPIEN_";1////"_DVBTRANS
- DO ^DIE
- +21 SET DR="1.1////"_DVBSTAT_";1.2////"_DVBERR
- DO ^DIE
- +22 SET DVBNUM=DA
- +23 SET DVBI=""
- FOR
- SET DVBI=$ORDER(DVBRPD(DVBI))
- if DVBI=""
- QUIT
- Begin DoDot:1
- +24 SET DA(1)=DVBNUM
- +25 SET DIC="^DVB(396.21,"_DA(1)_",2,"
- SET DIC(0)="L"
- +26 DO ^DIC
- SET DA=+Y
- +27 SET DIE=DIC
- +28 SET DVBRPC=$PIECE(DVBRPD(DVBI),U)
- SET DVBAIEN=$PIECE(DVBRPD(DVBI),U,2)
- +29 SET DVBN1=$PIECE(DVBRPD(DVBI),U,3,100)
- +30 SET DR=".01////"_DVBRPC_";.02////"_DVBAIEN_";.03////"_DVBN1
- +31 DO ^DIE
- End DoDot:1
- +32 KILL DIC,DIE,DA,DR,DIRUT
- +33 QUIT
- +34 ;
- PURGEMET(DVBRTN,DUZ,DVBDTP) ;
- +1 ;
- +2 ;input: DUZ user must have the DVBA METRICS DATA PURGE key
- +3 ; : Date to purge up to
- +4 NEW DVBDT,DVBDA,DVBKEY,DVBDATE
- +5 IF DUZ=""
- SET DVBRTN="0^Missing DUZ"
- QUIT
- +6 IF DVBDTP=""
- SET DVBRTN="0^Missing Date"
- QUIT
- +7 SET X=DVBDTP
- DO ^%DT
- SET DVBDATE=Y
- +8 DO OWNSKEY^XUSRB(.DVBKEY,"DVBA CAPRI METRICS PURGE",DUZ)
- +9 IF DVBKEY(0)=0
- SET DVBRTN="0^Missing security key"
- QUIT
- +10 SET DVBDT=""
- FOR
- SET DVBDT=$ORDER(^DVB(396.21,"B",DVBDT))
- if DVBDT=""
- QUIT
- Begin DoDot:1
- +11 SET DVBDA=""
- FOR
- SET DVBDA=$ORDER(^DVB(396.21,"B",DVBDT,DVBDA))
- if DVBDA=""
- QUIT
- Begin DoDot:2
- +12 IF $PIECE(DVBDT,".")>DVBDATE
- QUIT
- +13 KILL DIC,DA,DIK
- +14 SET DIC="^DVB(396.21,"
- SET DA=DVBDA
- +15 SET DIK=DIC
- DO ^DIK
- KILL DIK,DIC
- +16 SET DVBRTN=1
- End DoDot:2
- End DoDot:1
- +17 IF $GET(DVBRTN)'=1
- SET DVBRTN="-1"
- +18 QUIT
- PURGEOPT ;
- +1 WRITE !!,"CAPRI CLINICAL DOCUMENTS EFOLDER METRIC DATA PURGE",!!
- +2 SET DIR("?")="Enter date to purge CAPRI Clinical Documents EFolder Metrics file up to. For Example,to purge from today and older enter today's date"
- +3 SET DIR("A")="Enter date to purge CAPRI Clinical Documents EFolder Metrics file."
- +4 SET DIR(0)="D"
- DO ^DIR
- KILL DIR
- if $DATA(DIRUT)!($DATA(DTOUT))
- QUIT
- +5 DO PURGEMET(.DVBRTN,DUZ,Y)
- +6 IF DVBRTN["Miss"
- WRITE !!,"Missing Security Key, please check with your manager for additional assistance"
- QUIT
- +7 IF DVBRTN'=1
- WRITE !!,"No records were purged",!!
- DO PURGEOPT
- QUIT
- +8 IF DVBRTN=1
- WRITE !!,"Purge completed"
- +9 QUIT
- ALL(DVBLIST) ;
- +1 KILL DVBLIST
- +2 NEW DVBCNT,DVBPARAM,DVBVAL,DVBPAR,DVBSIY,DVBSIEN,DVBZ,DVBERR
- +3 SET DVBCNT=0
- +4 SET DVBPARAM=""
- FOR
- SET DVBPARAM=$ORDER(^XTV(8989.51,"B",DVBPARAM))
- if DVBPARAM=""
- QUIT
- Begin DoDot:1
- +5 SET DVBPAR=""
- FOR
- SET DVBPAR=$ORDER(^XTV(8989.51,"B",DVBPARAM,DVBPAR))
- if DVBPAR=""
- QUIT
- Begin DoDot:2
- +6 SET DVBZ="30*"
- KILL DVBSIY
- DO GETS^DIQ(8989.51,DVBPAR,DVBZ,"I","DVBSIY","DVBERR")
- IF $DATA(DVBERR)
- QUIT
- +7 SET DVBSIEN=""
- FOR
- SET DVBSIEN=$ORDER(DVBSIY(8989.513,DVBSIEN))
- if DVBSIEN=""
- QUIT
- Begin DoDot:3
- +8 NEW DVBENT
- SET DVBENT=DVBSIY(8989.513,DVBSIEN,.02,"I")
- IF DVBENT'=9.4
- QUIT
- +9 IF DVBPARAM["XPAR"
- QUIT
- +10 SET DVBVAL=$$GET^XPAR("ALL",DVBPARAM,1,"Q")
- +11 SET DVBLIST(DVBCNT)=DVBPARAM_U_DVBVAL
- +12 SET DVBCNT=DVBCNT+1
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +13 QUIT
- SPECADD(DVBMSG,DVBNAME) ;
- +1 ;adds entry to Special Considerations
- +2 IF $GET(DVBNAME)=""
- SET DVBMSG="0^Missing Special Considerations name"
- QUIT
- +3 KILL DVBMSG
- SET DVBMSG=""
- SET DVBIEN=0
- +4 FOR
- SET DVBIEN=$ORDER(^DVB(396.25,DVBIEN))
- if DVBIEN=""!('DVBIEN)
- QUIT
- Begin DoDot:1
- +5 IF $PIECE(^DVB(396.25,DVBIEN,0),U,1)=DVBNAME
- SET DVBMSG="0^Duplicate"
- +6 QUIT
- End DoDot:1
- +7 IF DVBMSG=""
- Begin DoDot:1
- +8 KILL DIC,DO,DIE,DA,DR,DLAYGO,X,Y
- +9 NEW DIERR
- +10 SET DIC=396.25
- SET DIC(0)="Z"
- SET X=DVBNAME
- DO FILE^DICN
- +11 SET (DA)=+Y
- SET DIE=DIC
- +12 SET DR=".02////1"
- DO ^DIE
- +13 IF $DATA(DIERR)
- SET DVBMSG="0^Record not added"
- +14 IF '$DATA(DIERR)
- SET DVBMSG="1^Record added"
- +15 KILL DIC,DO,DIE,DA,DR,DLAYGO,X,Y
- +16 QUIT
- End DoDot:1
- +17 QUIT
- SPECDIS(DVBMSG,DVBIEN,DVBSTAT) ;
- +1 ;disables entry in Special Considerations
- +2 NEW DIERR
- +3 KILL DIC,DIE,DA,DR,DLAYGO,X,Y
- +4 IF $GET(DVBIEN)=""
- SET DVBMSG="0^Missing IEN"
- QUIT
- +5 IF $GET(DVBSTAT)=""
- SET DVBMSG="0^Missing Status"
- QUIT
- +6 SET DA=DVBIEN
- SET (DLAYGO,DIE)="^DVB(396.25,"
- SET DIC(0)="L"
- +7 SET DR=".02////"_DVBSTAT
- DO ^DIE
- +8 IF $DATA(DIERR)
- SET DVBMSG="0^Record not disabled"
- +9 IF '$DATA(DIERR)
- SET DVBMSG="1^Record disabled"
- +10 KILL DIC,DIE,DA,DR,DLAYGO,X,Y
- +11 QUIT
- LISTSC(DVBMSG) ;
- +1 ;list inactive Special Considerations
- +2 NEW DVBIEN,DVBCNT,DVBRET
- +3 KILL ^TMP("DVBLSTSC",$JOB)
- +4 SET DVBIEN=0
- SET DVBCNT=0
- +5 FOR
- SET DVBIEN=$ORDER(^DVB(396.25,DVBIEN))
- if DVBIEN=""!('DVBIEN)
- QUIT
- Begin DoDot:1
- +6 if $GET(^DVB(396.25,DVBIEN,0))=""
- QUIT
- +7 if $PIECE($GET(^DVB(396.25,DVBIEN,0)),U,2)'=0
- QUIT
- +8 SET DVBRET(DVBCNT)=$PIECE(^DVB(396.25,DVBIEN,0),"^",1)_"^"_DVBIEN
- +9 MERGE ^TMP("DVBLSTSC",$JOB,DVBCNT)=DVBRET(DVBCNT)
- +10 SET DVBCNT=DVBCNT+1
- End DoDot:1
- +11 SET DVBMSG=$NAME(^TMP("DVBLSTSC",$JOB))
- +12 QUIT